gloss-1.13.1.2/0000755000000000000000000000000007346545000011255 5ustar0000000000000000gloss-1.13.1.2/Graphics/0000755000000000000000000000000007346545000013015 5ustar0000000000000000gloss-1.13.1.2/Graphics/Gloss.hs0000644000000000000000000000607607346545000014451 0ustar0000000000000000 -- | Gloss 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 Graphics.Gloss -- 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`. -- -- Gloss uses OpenGL under the hood, but you don't have to worry about any of that. -- -- Gloss programs should be compiled with @-threaded@, otherwise the GHC runtime -- will limit the frame-rate to around 20Hz. -- -- To build gloss using the GLFW window manager instead of GLUT use -- @cabal install gloss --flags=\"GLFW -GLUT\"@ -- -- @ -- Release Notes: -- -- For 1.13.1: -- Thanks to Thaler Jonathan -- * Repaired GLFW backend. -- Thanks to Samuel Gfrörer -- * Support for bitmap sections. -- Thanks to Basile Henry -- * Handle resize events in playField driver. -- -- For 1.12.1: -- Thanks to Trevor McDonell -- * Travis CI integration, general cleanups. -- -- For 1.11.1: -- Thanks to Lars Wyssard -- * Use default display resolution in full-screen mode. -- -- For 1.10.1: -- * Gloss no longer consumes CPU time when displaying static pictures. -- * Added displayIO wrapper for mostly static pictures, eg when -- plotting graphs generated from infrequently updated files. -- * Allow viewport to be scaled with control-left-click drag. -- * Rotation of viewport changed to alt-left-click drag. -- * Preserve current colour when rendering bitmpaps. -- * Changed to proper sum-of-squares colour mixing, rather than naive -- addition of components which was causing mixed colours to be too dark. -- Thanks to Thomas DuBuisson -- * Allow bitmaps to be specified in RGBA byte order as well as ABGR. -- Thanks to Gabriel Gonzalez -- * Package definitions for building with Stack. -- @ -- -- For more information, check out . -- module Graphics.Gloss ( module Graphics.Gloss.Data.Picture , module Graphics.Gloss.Data.Color , module Graphics.Gloss.Data.Bitmap , Display(..) , display , animate , simulate , play) where import Graphics.Gloss.Data.Display import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.Color import Graphics.Gloss.Data.Bitmap import Graphics.Gloss.Interface.Pure.Display import Graphics.Gloss.Interface.Pure.Animate import Graphics.Gloss.Interface.Pure.Simulate import Graphics.Gloss.Interface.Pure.Game gloss-1.13.1.2/Graphics/Gloss/Data/0000755000000000000000000000000007346545000014755 5ustar0000000000000000gloss-1.13.1.2/Graphics/Gloss/Data/Bitmap.hs0000644000000000000000000000066407346545000016533 0ustar0000000000000000 -- | Functions to load bitmap data from various places. module Graphics.Gloss.Data.Bitmap ( Rectangle(..) , BitmapData, bitmapSize , BitmapFormat(..), RowOrder(..), PixelFormat(..) , bitmapOfForeignPtr , bitmapDataOfForeignPtr , bitmapOfByteString , bitmapDataOfByteString , bitmapOfBMP , bitmapDataOfBMP , loadBMP) where import Graphics.Gloss.Rendering gloss-1.13.1.2/Graphics/Gloss/Data/Color.hs0000644000000000000000000001147407346545000016376 0ustar0000000000000000 -- | Predefined and custom colors. module Graphics.Gloss.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 Graphics.Gloss.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 gloss-1.13.1.2/Graphics/Gloss/Data/Controller.hs0000644000000000000000000000074307346545000017440 0ustar0000000000000000 module Graphics.Gloss.Data.Controller ( Controller (..)) where import Graphics.Gloss.Data.ViewPort -- | Functions to asynchronously control a `Gloss` display. data Controller = Controller { -- | Indicate that we want the picture to be redrawn. controllerSetRedraw :: IO () -- | Modify the current viewport, also indicating that it should be redrawn. , controllerModifyViewPort :: (ViewPort -> IO ViewPort) -> IO () } gloss-1.13.1.2/Graphics/Gloss/Data/Display.hs0000644000000000000000000000052707346545000016722 0ustar0000000000000000 module Graphics.Gloss.Data.Display (Display(..)) where -- | Describes how Gloss 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) gloss-1.13.1.2/Graphics/Gloss/Data/Picture.hs0000644000000000000000000001274707346545000016737 0ustar0000000000000000 module Graphics.Gloss.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 Graphics.Gloss.Rendering import Graphics.Gloss.Geometry.Angle -- 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 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 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 gloss-1.13.1.2/Graphics/Gloss/Data/Point.hs0000644000000000000000000000120007346545000016373 0ustar0000000000000000module Graphics.Gloss.Data.Point ( Point, Path , pointInBox) where import Graphics.Gloss.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 gloss-1.13.1.2/Graphics/Gloss/Data/Point/0000755000000000000000000000000007346545000016046 5ustar0000000000000000gloss-1.13.1.2/Graphics/Gloss/Data/Point/Arithmetic.hs0000644000000000000000000000221307346545000020471 0ustar0000000000000000{-# 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 Graphics.Gloss.Data.Point.Arithmetic ( Point , (+) , (-) , (*) , negate ) where import Prelude (Float) import qualified Prelude as P import Graphics.Gloss.Rendering (Point) 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') gloss-1.13.1.2/Graphics/Gloss/Data/Vector.hs0000644000000000000000000000371707346545000016563 0ustar0000000000000000{-# OPTIONS -fno-warn-missing-methods #-} {-# LANGUAGE TypeSynonymInstances #-} -- | Geometric functions concerning vectors. module Graphics.Gloss.Data.Vector ( Vector , magV , argV , dotV , detV , mulSV , rotateV , angleVV , normalizeV , unitVectorAtAngle ) where import Graphics.Gloss.Data.Picture import Graphics.Gloss.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 #-} gloss-1.13.1.2/Graphics/Gloss/Data/ViewPort.hs0000644000000000000000000000440507346545000017073 0ustar0000000000000000 module Graphics.Gloss.Data.ViewPort ( ViewPort(..) , viewPortInit , applyViewPortToPicture , invertViewPort ) where import Graphics.Gloss.Data.Picture import qualified Graphics.Gloss.Data.Point.Arithmetic 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 { -- | Global translation. viewPortTranslate :: !(Float, Float) -- | Global rotation (in degrees). , viewPortRotate :: !Float -- | Global scaling (of both x and y coordinates). , viewPortScale :: !Float } -- | 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 #-} gloss-1.13.1.2/Graphics/Gloss/Data/ViewState.hs0000644000000000000000000003310007346545000017221 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} module Graphics.Gloss.Data.ViewState ( Command (..) , CommandConfig , defaultCommandConfig , ViewState (..) , viewStateInit , viewStateInitWithConfig , updateViewStateWithEvent , updateViewStateWithEventMaybe) where import Graphics.Gloss.Data.Vector import Graphics.Gloss.Data.ViewPort import Graphics.Gloss.Geometry.Angle import Graphics.Gloss.Internals.Interface.Backend import Graphics.Gloss.Internals.Interface.Event import qualified Data.Map as Map import Data.Map (Map) import Data.Maybe import Control.Monad (mplus) import qualified Graphics.Gloss.Data.Point.Arithmetic as Pt -- | 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 gloss 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 gloss 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 { -- | 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. viewStateCommands :: !(Map Command [(Key, Maybe Modifiers)]) -- | How much to scale the world by for each step of the mouse wheel. , viewStateScaleStep :: !Float -- | How many degrees to rotate the world by for each pixel of x motion. , viewStateRotateFactor :: !Float -- | Ratio to scale the world by for each pixel of y motion. , viewStateScaleFactor :: !Float -- | During viewport translation, -- where the mouse was clicked on the window to start the translate. , viewStateTranslateMark :: !(Maybe (Float, Float)) -- | During viewport rotation, -- where the mouse was clicked on the window to starte the rotate. , viewStateRotateMark :: !(Maybe (Float, Float)) -- | During viewport scale, -- where the mouse was clicked on the window to start the scale. , viewStateScaleMark :: !(Maybe (Float, Float)) -- | The current viewport. , viewStateViewPort :: 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 gloss-1.13.1.2/Graphics/Gloss/Geometry/0000755000000000000000000000000007346545000015677 5ustar0000000000000000gloss-1.13.1.2/Graphics/Gloss/Geometry/Angle.hs0000644000000000000000000000127007346545000017261 0ustar0000000000000000-- | Geometric functions concerning angles. If not otherwise specified, all angles are in radians. module Graphics.Gloss.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 #-} gloss-1.13.1.2/Graphics/Gloss/Geometry/Line.hs0000644000000000000000000002146307346545000017130 0ustar0000000000000000{-# 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 Graphics.Gloss.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 Graphics.Gloss.Data.Point import Graphics.Gloss.Data.Vector import qualified Graphics.Gloss.Data.Point.Arithmetic as Pt -- | 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 gloss-1.13.1.2/Graphics/Gloss/Interface/0000755000000000000000000000000007346545000016004 5ustar0000000000000000gloss-1.13.1.2/Graphics/Gloss/Interface/Environment.hs0000644000000000000000000000116107346545000020643 0ustar0000000000000000module Graphics.Gloss.Interface.Environment where import Graphics.Gloss.Internals.Interface.Backend.GLUT import qualified Graphics.UI.GLUT as GLUT import qualified Graphics.Rendering.OpenGL as GL import Data.IORef -- | Get the size of the screen, in pixels. -- -- This will be the size of the rendered gloss image when -- fullscreen mode is enabled. -- getScreenSize :: IO (Int, Int) getScreenSize = do backendStateRef <- newIORef glutStateInit initializeGLUT backendStateRef False GL.Size width height <- GLUT.get GLUT.screenSize return (fromIntegral width, fromIntegral height) gloss-1.13.1.2/Graphics/Gloss/Interface/IO/0000755000000000000000000000000007346545000016313 5ustar0000000000000000gloss-1.13.1.2/Graphics/Gloss/Interface/IO/Animate.hs0000644000000000000000000000405307346545000020227 0ustar0000000000000000 -- | Animate a picture in a window. module Graphics.Gloss.Interface.IO.Animate ( module Graphics.Gloss.Data.Display , module Graphics.Gloss.Data.Picture , module Graphics.Gloss.Data.Color , animateIO , animateFixedIO , Controller (..)) where import Graphics.Gloss.Data.Display import Graphics.Gloss.Data.Controller import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.Color import Graphics.Gloss.Internals.Interface.Animate import Graphics.Gloss.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 gloss-1.13.1.2/Graphics/Gloss/Interface/IO/Display.hs0000644000000000000000000000575107346545000020264 0ustar0000000000000000 -- | Display mode is for drawing a static picture. module Graphics.Gloss.Interface.IO.Display ( module Graphics.Gloss.Data.Display , module Graphics.Gloss.Data.Picture , module Graphics.Gloss.Data.Color , displayIO , Controller (..)) where import Graphics.Gloss.Data.Display import Graphics.Gloss.Data.Controller import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.Color import Graphics.Gloss.Internals.Interface.Display import Graphics.Gloss.Internals.Interface.Backend -- | 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 GLUT and GLFW window managers. 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 gloss-1.13.1.2/Graphics/Gloss/Interface/IO/Game.hs0000644000000000000000000000330707346545000017523 0ustar0000000000000000{-# 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 Graphics.Gloss.Interface.IO.Game ( module Graphics.Gloss.Data.Display , module Graphics.Gloss.Data.Picture , module Graphics.Gloss.Data.Color , playIO , Event(..), Key(..), SpecialKey(..), MouseButton(..), KeyState(..), Modifiers(..)) where import Graphics.Gloss.Data.Display import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.Color import Graphics.Gloss.Internals.Interface.Game import Graphics.Gloss.Internals.Interface.Backend -- | 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 gloss-1.13.1.2/Graphics/Gloss/Interface/IO/Interact.hs0000644000000000000000000000306007346545000020417 0ustar0000000000000000 -- | Display mode is for drawing a static picture. module Graphics.Gloss.Interface.IO.Interact ( module Graphics.Gloss.Data.Display , module Graphics.Gloss.Data.Picture , module Graphics.Gloss.Data.Color , interactIO , Controller (..) , Event(..), Key(..), SpecialKey(..), MouseButton(..), KeyState(..), Modifiers(..)) where import Graphics.Gloss.Data.Display import Graphics.Gloss.Data.Controller import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.Color import Graphics.Gloss.Internals.Interface.Event import Graphics.Gloss.Internals.Interface.Interact import Graphics.Gloss.Internals.Interface.Backend -- | 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 gloss-1.13.1.2/Graphics/Gloss/Interface/IO/Simulate.hs0000644000000000000000000000301507346545000020431 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} -- We export this stuff separately so we don't clutter up the -- API of the Graphics.Gloss 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 Graphics.Gloss.Interface.IO.Simulate ( module Graphics.Gloss.Data.Display , module Graphics.Gloss.Data.Picture , module Graphics.Gloss.Data.Color , simulateIO , ViewPort(..)) where import Graphics.Gloss.Data.Display import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.Color import Graphics.Gloss.Data.ViewPort import Graphics.Gloss.Internals.Interface.Simulate import Graphics.Gloss.Internals.Interface.Backend 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 gloss-1.13.1.2/Graphics/Gloss/Interface/Pure/0000755000000000000000000000000007346545000016717 5ustar0000000000000000gloss-1.13.1.2/Graphics/Gloss/Interface/Pure/Animate.hs0000644000000000000000000000221207346545000020626 0ustar0000000000000000 -- | Display mode is for drawing a static picture. module Graphics.Gloss.Interface.Pure.Animate ( module Graphics.Gloss.Data.Display , module Graphics.Gloss.Data.Picture , module Graphics.Gloss.Data.Color , animate) where import Graphics.Gloss.Data.Display import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.Color import Graphics.Gloss.Internals.Interface.Animate import Graphics.Gloss.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 ())) gloss-1.13.1.2/Graphics/Gloss/Interface/Pure/Display.hs0000644000000000000000000000157607346545000020671 0ustar0000000000000000 -- | Display mode is for drawing a static picture. module Graphics.Gloss.Interface.Pure.Display ( module Graphics.Gloss.Data.Display , module Graphics.Gloss.Data.Picture , module Graphics.Gloss.Data.Color , display) where import Graphics.Gloss.Data.Display import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.Color import Graphics.Gloss.Internals.Interface.Display import Graphics.Gloss.Internals.Interface.Backend -- | 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 ())) gloss-1.13.1.2/Graphics/Gloss/Interface/Pure/Game.hs0000644000000000000000000000377407346545000020137 0ustar0000000000000000{-# LANGUAGE ExplicitForAll #-} -- We export this stuff separately so we don't clutter up the -- API of the Graphics.Gloss 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 Graphics.Gloss.Interface.Pure.Game ( module Graphics.Gloss.Data.Display , module Graphics.Gloss.Data.Picture , module Graphics.Gloss.Data.Color , play , Event(..), Key(..), SpecialKey(..), MouseButton(..), KeyState(..), Modifiers(..)) where import Graphics.Gloss.Data.Display import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.Color import Graphics.Gloss.Internals.Interface.Game import Graphics.Gloss.Internals.Interface.Backend -- | 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 () gloss-1.13.1.2/Graphics/Gloss/Interface/Pure/Simulate.hs0000644000000000000000000000406607346545000021044 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} -- We export this stuff separately so we don't clutter up the -- API of the Graphics.Gloss 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 Graphics.Gloss.Interface.Pure.Simulate ( module Graphics.Gloss.Data.Display , module Graphics.Gloss.Data.Picture , module Graphics.Gloss.Data.Color , simulate , ViewPort(..)) where import Graphics.Gloss.Data.Display import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.Color import Graphics.Gloss.Data.ViewPort import Graphics.Gloss.Internals.Interface.Simulate import Graphics.Gloss.Internals.Interface.Backend -- | 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 () gloss-1.13.1.2/Graphics/Gloss/Internals/0000755000000000000000000000000007346545000016043 5ustar0000000000000000gloss-1.13.1.2/Graphics/Gloss/Internals/Color.hs0000644000000000000000000000106607346545000017460 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} module Graphics.Gloss.Internals.Color where import Graphics.Gloss.Data.Color import qualified Graphics.Rendering.OpenGL.GL 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 gloss-1.13.1.2/Graphics/Gloss/Internals/Interface/0000755000000000000000000000000007346545000017743 5ustar0000000000000000gloss-1.13.1.2/Graphics/Gloss/Internals/Interface/Animate.hs0000644000000000000000000000756607346545000021673 0ustar0000000000000000 module Graphics.Gloss.Internals.Interface.Animate (animateWithBackendIO) where import Graphics.Gloss.Data.Color import Graphics.Gloss.Data.Controller import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.ViewPort import Graphics.Gloss.Data.ViewState import Graphics.Gloss.Rendering import Graphics.Gloss.Internals.Interface.Backend import Graphics.Gloss.Internals.Interface.Window import Graphics.Gloss.Internals.Interface.Common.Exit import Graphics.Gloss.Internals.Interface.ViewState.KeyMouse import Graphics.Gloss.Internals.Interface.ViewState.Motion import Graphics.Gloss.Internals.Interface.ViewState.Reshape import Graphics.Gloss.Internals.Interface.Animate.Timing import qualified Graphics.Gloss.Internals.Interface.Animate.State as AN import qualified Graphics.Gloss.Internals.Interface.Callback as Callback import Data.IORef import Control.Monad import System.Mem import GHC.Float (double2Float) 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 gloss-1.13.1.2/Graphics/Gloss/Internals/Interface/Animate/0000755000000000000000000000000007346545000021321 5ustar0000000000000000gloss-1.13.1.2/Graphics/Gloss/Internals/Interface/Animate/State.hs0000644000000000000000000000353707346545000022745 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} module Graphics.Gloss.Internals.Interface.Animate.State ( State (..) , stateInit ) where -- | Animation State data State = State { -- | Whether the animation is running. stateAnimate :: !Bool -- | How many times we've entered the animation loop. , stateAnimateCount :: !Integer -- | Whether this is the first frame of the animation. , stateAnimateStart :: !Bool -- | Number of msec the animation has been running for , stateAnimateTime :: !Double -- | The time when we entered the display callback for the current frame. , stateDisplayTime :: !Double , stateDisplayTimeLast :: !Double -- | Clamp the minimum time between frames to this value (in seconds) -- Setting this to < 10ms probably isn't worthwhile. , stateDisplayTimeClamp :: !Double -- | The time when the last call to the users render function finished. , stateGateTimeStart :: !Double -- | The time when displayInWindow last finished (after sleeping to clamp fps). , stateGateTimeEnd :: !Double -- | How long it took to draw this frame , stateGateTimeElapsed :: !Double } 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 } gloss-1.13.1.2/Graphics/Gloss/Internals/Interface/Animate/Timing.hs0000644000000000000000000000634007346545000023107 0ustar0000000000000000{-# 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 Graphics.Gloss.Internals.Interface.Animate.Timing ( animateBegin , animateEnd ) where import Graphics.Gloss.Internals.Interface.Backend import Graphics.Gloss.Internals.Interface.Animate.State 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 gloss-1.13.1.2/Graphics/Gloss/Internals/Interface/Backend.hs0000644000000000000000000000167507346545000021637 0ustar0000000000000000{-# LANGUAGE CPP #-} -- Import window managed backend specific modules. -- We need to use #ifdef here because if the backend library hasn't been installed -- then we won't be able to build it, so it can't be in the import list. module Graphics.Gloss.Internals.Interface.Backend ( module Graphics.Gloss.Internals.Interface.Backend.Types #ifdef WITHGLFW , module Graphics.Gloss.Internals.Interface.Backend.GLFW #endif #ifdef WITHGLUT , module Graphics.Gloss.Internals.Interface.Backend.GLUT #endif , defaultBackendState) where import Graphics.Gloss.Internals.Interface.Backend.Types #ifdef WITHGLFW import Graphics.Gloss.Internals.Interface.Backend.GLFW #endif #ifdef WITHGLUT import Graphics.Gloss.Internals.Interface.Backend.GLUT #endif #ifdef WITHGLUT defaultBackendState :: GLUTState #elif WITHGLFW defaultBackendState :: GLFWState #else #error No default backend defined #endif defaultBackendState = initBackendState gloss-1.13.1.2/Graphics/Gloss/Internals/Interface/Backend/0000755000000000000000000000000007346545000021272 5ustar0000000000000000gloss-1.13.1.2/Graphics/Gloss/Internals/Interface/Backend/GLFW.hs0000644000000000000000000005715707346545000022404 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE CPP #-} -- | Support for using GLFW as the window manager backend. module Graphics.Gloss.Internals.Interface.Backend.GLFW (GLFWState) where import Data.IORef import Data.Char (toLower) import Data.Maybe (fromJust) import Control.Concurrent import Control.Monad import Graphics.Gloss.Data.Display -- import Graphics.UI.GLFW (WindowValue(..)) import qualified Graphics.UI.GLFW as GLFW import qualified Graphics.Rendering.OpenGL as GL import qualified Control.Exception as X -- [Note: FreeGlut] -- ~~~~~~~~~~~~~~~~ -- We use GLUT for font rendering. -- On freeglut-based installations (usually linux) we need to explicitly -- initialize GLUT before we can use any of it's functions. -- --- We also need to deinitialize (exit) GLUT when we close the GLFW -- window, otherwise opening a gloss window again from GHCi will crash. -- For the OS X and Windows version of GLUT there are no such restrictions. -- -- We assume also assume that only linux installations use freeglut. -- #ifdef linux_HOST_OS import qualified Graphics.UI.GLUT as GLUT #endif import Graphics.Gloss.Internals.Interface.Backend.Types -- | State of the GLFW backend library. data GLFWState = GLFWState { -- | Status of Ctrl, Alt or Shift (Up or Down?) modifiers :: Modifiers -- | Latest mouse position , mousePosition :: (Int,Int) -- | Latest mousewheel position , mouseWheelPos :: Int -- | Does the screen need to be redrawn? , dirtyScreen :: Bool -- | Action that draws on the screen , display :: IO () -- | Action perforrmed when idling , idle :: IO () -- | The Window Handle , winHdl :: GLFW.Window } -- | Initial GLFW state. glfwStateInit :: GLFWState glfwStateInit = GLFWState { modifiers = Modifiers Up Up Up , mousePosition = (0, 0) , mouseWheelPos = 0 , dirtyScreen = True , display = return () , idle = return () } 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) elapsedTime = (\_ -> GLFW.getTime >>= \mt -> return $ fromJust mt) sleep = (\_ sec -> threadDelay (floor (sec * fromIntegral 1000000))) --GLFW.sleep sec) -- Initialise ----------------------------------------------------------------- -- | Initialise the GLFW backend. initializeGLFW :: IORef GLFWState -> Bool-> IO () initializeGLFW _ debug = do _ <- GLFW.init glfwVersion <- GLFW.getVersion #ifdef linux_HOST_OS -- See [Note: FreeGlut] for why we need this. (_progName, _args) <- GLUT.getArgsAndInitialize #endif 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 #ifdef linux_HOST_OS -- See [Note: FreeGlut] on why we exit GLUT for Linux GLUT.exit #endif win <- windowHandle ref GLFW.destroyWindow win -- 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 { winHdl = fromJust win}) uncurry (GLFW.setWindowPos (fromJust win)) pos -- 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 { winHdl = fromJust 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 -- 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) -- 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 #ifdef linux_HOST_OS -- See [Note: FreeGlut] for why we need this. GLUT.exit #endif 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 Gloss 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 Gloss 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 Gloss 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 Gloss 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 Gloss 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 Gloss 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 = X.catch go exit where exit :: X.SomeException -> IO () exit e = print e >> exitGLFW stateRef go :: IO () go = do win <- windowHandle stateRef windowIsOpen <- GLFW.windowShouldClose win when windowIsOpen $ do GLFW.pollEvents dirty <- fmap dirtyScreen $ readIORef stateRef when dirty $ do s <- readIORef stateRef display s GLFW.swapBuffers win modifyIORef' stateRef $ \s -> s { dirtyScreen = False } (readIORef stateRef) >>= (\s -> idle s) threadDelay 1000 runMainLoopGLFW stateRef -- 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 8gloss-1.13.1.2/Graphics/Gloss/Internals/Interface/Backend/GLUT.hs0000644000000000000000000004155407346545000022412 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} module Graphics.Gloss.Internals.Interface.Backend.GLUT (GLUTState,glutStateInit,initializeGLUT) where import Data.IORef import Control.Monad import Control.Concurrent import Graphics.UI.GLUT (get,($=)) import qualified Graphics.Rendering.OpenGL as GL import qualified Graphics.UI.GLUT as GLUT import qualified System.Exit as System import Graphics.Gloss.Internals.Interface.Backend.Types import System.IO.Unsafe -- Were we to support freeglut only, we could use GLUT.get to discover -- whether we are initialized or not. If not, we do a quick initialize, -- get the screenzie, and then do GLUT.exit. This avoids the use of -- global variables. Unfortunately, there is no failsafe way to check -- whether glut is initialized in some older versions of glut, which is -- what we'd use instead of the global variable to get the required info. glutInitialized :: IORef Bool {-# NOINLINE glutInitialized #-} glutInitialized = unsafePerformIO $ do newIORef False -- | State information for the GLUT backend. data GLUTState = GLUTState { -- Count of total number of frames that we have drawn. glutStateFrameCount :: !Int -- Bool to remember if we've set the timeout callback. , glutStateHasTimeout :: Bool -- Bool to remember if we've set the idle callback. , glutStateHasIdle :: Bool } deriving Show -- | Initial GLUT state. glutStateInit :: GLUTState glutStateInit = GLUTState { glutStateFrameCount = 0 , glutStateHasTimeout = False , glutStateHasIdle = False } instance Backend GLUTState where initBackendState = glutStateInit initializeBackend = initializeGLUT -- non-freeglut doesn't like this: (\_ -> GLUT.leaveMainLoop) exitBackend = (\_ -> System.exitWith System.ExitSuccess) openWindow = openWindowGLUT dumpBackendState = dumpStateGLUT installDisplayCallback = installDisplayCallbackGLUT -- We can ask for this in freeglut, but it doesn't seem to work :(. -- (\_ -> GLUT.actionOnWindowClose $= GLUT.MainLoopReturns) installWindowCloseCallback = (\_ -> return ()) installReshapeCallback = installReshapeCallbackGLUT installKeyMouseCallback = installKeyMouseCallbackGLUT installMotionCallback = installMotionCallbackGLUT installIdleCallback = installIdleCallbackGLUT -- Call the GLUT mainloop. -- This function will return when something calls GLUT.leaveMainLoop runMainLoop _ = GLUT.mainLoop postRedisplay _ = GLUT.postRedisplay Nothing getWindowDimensions _ = do GL.Size sizeX sizeY <- get GLUT.windowSize return (fromEnum sizeX,fromEnum sizeY) elapsedTime _ = do t <- get GLUT.elapsedTime return $ (fromIntegral t) / 1000 sleep _ sec = do threadDelay (round $ sec * 1000000) -- Initialise ----------------------------------------------------------------- initializeGLUT :: IORef GLUTState -> Bool -> IO () initializeGLUT _ debug = do initialized <- readIORef glutInitialized if not initialized then do (_progName, _args) <- GLUT.getArgsAndInitialize glutVersion <- get GLUT.glutVersion when debug $ putStr $ " glutVersion = " ++ show glutVersion ++ "\n" GLUT.initialDisplayMode $= [ GLUT.RGBMode , GLUT.DoubleBuffered] writeIORef glutInitialized True -- See if our requested display mode is possible displayMode <- get GLUT.initialDisplayMode displayModePossible <- get GLUT.displayModePossible when debug $ do putStr $ " displayMode = " ++ show displayMode ++ "\n" ++ " possible = " ++ show displayModePossible ++ "\n" ++ "\n" else when debug (putStrLn "Already initialized") -- Open Window ---------------------------------------------------------------- openWindowGLUT :: IORef GLUTState -> Display -> IO () openWindowGLUT _ display = do -- Setup and create a new window. -- Be sure to set initialWindow{Position,Size} before calling -- createWindow. If we don't do this we get wierd half-created -- windows some of the time. case display of InWindow windowName (sizeX, sizeY) (posX, posY) -> do GLUT.initialWindowSize $= GL.Size (fromIntegral sizeX) (fromIntegral sizeY) GLUT.initialWindowPosition $= GL.Position (fromIntegral posX) (fromIntegral posY) _ <- GLUT.createWindow windowName GLUT.windowSize $= GL.Size (fromIntegral sizeX) (fromIntegral sizeY) FullScreen -> do size <- get GLUT.screenSize GLUT.initialWindowSize $= size _ <- GLUT.createWindow "Gloss Application" GLUT.fullScreen -- Switch some things. -- auto repeat interferes with key up / key down checks. -- BUGS: this doesn't seem to work? GLUT.perWindowKeyRepeat $= GLUT.PerWindowKeyRepeatOff -- Dump State ----------------------------------------------------------------- dumpStateGLUT :: IORef GLUTState -> IO () dumpStateGLUT _ = do wbw <- get GLUT.windowBorderWidth whh <- get GLUT.windowHeaderHeight rgba <- get GLUT.rgba rgbaBD <- get GLUT.rgbaBufferDepths colorBD <- get GLUT.colorBufferDepth depthBD <- get GLUT.depthBufferDepth accumBD <- get GLUT.accumBufferDepths stencilBD <- get GLUT.stencilBufferDepth doubleBuffered <- get GLUT.doubleBuffered colorMask <- get GLUT.colorMask depthMask <- get GLUT.depthMask putStr $ "* dumpGlutState\n" ++ " windowBorderWidth = " ++ show wbw ++ "\n" ++ " windowHeaderHeight = " ++ show whh ++ "\n" ++ " rgba = " ++ show rgba ++ "\n" ++ " depth rgba = " ++ show rgbaBD ++ "\n" ++ " color = " ++ show colorBD ++ "\n" ++ " depth = " ++ show depthBD ++ "\n" ++ " accum = " ++ show accumBD ++ "\n" ++ " stencil = " ++ show stencilBD ++ "\n" ++ " doubleBuffered = " ++ show doubleBuffered ++ "\n" ++ " mask color = " ++ show colorMask ++ "\n" ++ " depth = " ++ show depthMask ++ "\n" ++ "\n" -- Display Callback ----------------------------------------------------------- installDisplayCallbackGLUT :: IORef GLUTState -> [Callback] -> IO () installDisplayCallbackGLUT ref callbacks = GLUT.displayCallback $= callbackDisplay ref callbacks callbackDisplay :: IORef GLUTState -> [Callback] -> IO () callbackDisplay refState callbacks = do -- Clear the display GL.clear [GL.ColorBuffer, GL.DepthBuffer] GL.color $ GL.Color4 0 0 0 (1 :: GL.GLfloat) -- Run all the display callbacks to draw the window contents. let funs = [f refState | (Display f) <- callbacks] sequence_ funs -- Swap front and back buffers GLUT.swapBuffers -- Timeout. -- When there is no idle callback set the GLUT mainloop will block -- forever waiting for display events. This prevents us from updating -- the display on external events like files changing. The API doesn't -- provide a way to wake it up on these other events. -- -- Set a timeout so that GLUT will return from its mainloop after a -- a second and give us a chance to check for other events. -- -- The alternative would be to set an Idle callback and spin the CPU. -- This is ok for real-time animations, but a CPU hog for mostly static -- displays. -- -- We only want to add a timeout when one doesn't already exist, -- otherwise we'll get both events. -- state <- readIORef refState when ( (not $ glutStateHasTimeout state) && (not $ glutStateHasIdle state)) $ do -- Setting the timer interrupt to 1sec keeps CPU usage for a -- single process to < 0.5% or so on OSX. This is the rate -- that the process is woken up, but GLUT will only actually -- call the display call if postRedisplay has been set. let msecHeartbeat = 1000 -- We're installing this callback on the first display -- call because it's a GLUT specific mechanism. -- We don't do the same thing for other Backends. GLUT.addTimerCallback msecHeartbeat $ timerCallback msecHeartbeat -- Rember that we've done this filthy hack. atomicModifyIORef' refState $ \s -> (s { glutStateHasTimeout = True }, ()) -- Don't report errors by default. -- The windows OpenGL implementation seems to complain for no reason. -- GLUT.reportErrors atomicModifyIORef' refState $ \s -> ( s { glutStateFrameCount = glutStateFrameCount s + 1 } , ()) return () -- | Oneshot timer callback that re-registers itself. timerCallback :: Int -> IO () timerCallback msec = do GLUT.addTimerCallback msec $ do timerCallback msec -- Reshape Callback ----------------------------------------------------------- installReshapeCallbackGLUT :: IORef GLUTState -> [Callback] -> IO () installReshapeCallbackGLUT ref callbacks = GLUT.reshapeCallback $= Just (callbackReshape ref callbacks) callbackReshape :: IORef GLUTState -> [Callback] -> GLUT.Size -> IO () callbackReshape ref callbacks (GLUT.Size sizeX sizeY) = sequence_ $ map (\f -> f (fromEnum sizeX, fromEnum sizeY)) [f ref | Reshape f <- callbacks] -- KeyMouse Callback ---------------------------------------------------------- installKeyMouseCallbackGLUT :: IORef GLUTState -> [Callback] -> IO () installKeyMouseCallbackGLUT ref callbacks = GLUT.keyboardMouseCallback $= Just (callbackKeyMouse ref callbacks) callbackKeyMouse :: IORef GLUTState -> [Callback] -> GLUT.Key -> GLUT.KeyState -> GLUT.Modifiers -> GLUT.Position -> IO () callbackKeyMouse ref callbacks key keystate modifiers (GLUT.Position posX posY) = sequence_ $ map (\f -> f key' keyState' modifiers' pos) [f ref | KeyMouse f <- callbacks] where key' = glutKeyToKey key keyState' = glutKeyStateToKeyState keystate modifiers' = glutModifiersToModifiers modifiers pos = (fromEnum posX, fromEnum posY) -- Motion Callback ------------------------------------------------------------ installMotionCallbackGLUT :: IORef GLUTState -> [Callback] -> IO () installMotionCallbackGLUT ref callbacks = do GLUT.motionCallback $= Just (callbackMotion ref callbacks) GLUT.passiveMotionCallback $= Just (callbackMotion ref callbacks) callbackMotion :: IORef GLUTState -> [Callback] -> GLUT.Position -> IO () callbackMotion ref callbacks (GLUT.Position posX posY) = do let pos = (fromEnum posX, fromEnum posY) sequence_ $ map (\f -> f pos) [f ref | Motion f <- callbacks] -- Idle Callback -------------------------------------------------------------- installIdleCallbackGLUT :: IORef GLUTState -> [Callback] -> IO () installIdleCallbackGLUT refState callbacks -- If the callback list does not actually contain an idle callback -- then don't install one that just does nothing. If we do then GLUT -- will still call us back after whenever it's idle and waste CPU time. | any isIdleCallback callbacks = do GLUT.idleCallback $= Just (callbackIdle refState callbacks) atomicModifyIORef' refState $ \state -> (state { glutStateHasIdle = True }, ()) | otherwise = return () -- | Call back when glut is idle. callbackIdle :: IORef GLUTState -> [Callback] -> IO () callbackIdle ref callbacks = sequence_ $ [f ref | Idle f <- callbacks] ------------------------------------------------------------------------------- -- | Convert GLUTs key codes to our internal ones. glutKeyToKey :: GLUT.Key -> Key glutKeyToKey key = case key of GLUT.Char '\32' -> SpecialKey KeySpace GLUT.Char '\13' -> SpecialKey KeyEnter GLUT.Char '\9' -> SpecialKey KeyTab GLUT.Char '\ESC' -> SpecialKey KeyEsc GLUT.Char '\DEL' -> SpecialKey KeyDelete GLUT.Char c -> Char c GLUT.SpecialKey GLUT.KeyF1 -> SpecialKey KeyF1 GLUT.SpecialKey GLUT.KeyF2 -> SpecialKey KeyF2 GLUT.SpecialKey GLUT.KeyF3 -> SpecialKey KeyF3 GLUT.SpecialKey GLUT.KeyF4 -> SpecialKey KeyF4 GLUT.SpecialKey GLUT.KeyF5 -> SpecialKey KeyF5 GLUT.SpecialKey GLUT.KeyF6 -> SpecialKey KeyF6 GLUT.SpecialKey GLUT.KeyF7 -> SpecialKey KeyF7 GLUT.SpecialKey GLUT.KeyF8 -> SpecialKey KeyF8 GLUT.SpecialKey GLUT.KeyF9 -> SpecialKey KeyF9 GLUT.SpecialKey GLUT.KeyF10 -> SpecialKey KeyF10 GLUT.SpecialKey GLUT.KeyF11 -> SpecialKey KeyF11 GLUT.SpecialKey GLUT.KeyF12 -> SpecialKey KeyF12 GLUT.SpecialKey GLUT.KeyLeft -> SpecialKey KeyLeft GLUT.SpecialKey GLUT.KeyUp -> SpecialKey KeyUp GLUT.SpecialKey GLUT.KeyRight -> SpecialKey KeyRight GLUT.SpecialKey GLUT.KeyDown -> SpecialKey KeyDown GLUT.SpecialKey GLUT.KeyPageUp -> SpecialKey KeyPageUp GLUT.SpecialKey GLUT.KeyPageDown -> SpecialKey KeyPageDown GLUT.SpecialKey GLUT.KeyHome -> SpecialKey KeyHome GLUT.SpecialKey GLUT.KeyEnd -> SpecialKey KeyEnd GLUT.SpecialKey GLUT.KeyInsert -> SpecialKey KeyInsert GLUT.SpecialKey GLUT.KeyNumLock -> SpecialKey KeyNumLock GLUT.SpecialKey GLUT.KeyBegin -> SpecialKey KeyBegin GLUT.SpecialKey GLUT.KeyDelete -> SpecialKey KeyDelete GLUT.SpecialKey (GLUT.KeyUnknown _) -> SpecialKey KeyUnknown GLUT.SpecialKey GLUT.KeyShiftL -> SpecialKey KeyShiftL GLUT.SpecialKey GLUT.KeyShiftR -> SpecialKey KeyShiftR GLUT.SpecialKey GLUT.KeyCtrlL -> SpecialKey KeyCtrlL GLUT.SpecialKey GLUT.KeyCtrlR -> SpecialKey KeyCtrlR GLUT.SpecialKey GLUT.KeyAltL -> SpecialKey KeyAltL GLUT.SpecialKey GLUT.KeyAltR -> SpecialKey KeyAltR GLUT.MouseButton GLUT.LeftButton -> MouseButton LeftButton GLUT.MouseButton GLUT.MiddleButton -> MouseButton MiddleButton GLUT.MouseButton GLUT.RightButton -> MouseButton RightButton GLUT.MouseButton GLUT.WheelUp -> MouseButton WheelUp GLUT.MouseButton GLUT.WheelDown -> MouseButton WheelDown GLUT.MouseButton (GLUT.AdditionalButton i) -> MouseButton (AdditionalButton i) -- | Convert GLUTs key states to our internal ones. glutKeyStateToKeyState :: GLUT.KeyState -> KeyState glutKeyStateToKeyState state = case state of GLUT.Down -> Down GLUT.Up -> Up -- | Convert GLUTs key states to our internal ones. glutModifiersToModifiers :: GLUT.Modifiers -> Modifiers glutModifiersToModifiers (GLUT.Modifiers a b c) = Modifiers (glutKeyStateToKeyState a) (glutKeyStateToKeyState b) (glutKeyStateToKeyState c) gloss-1.13.1.2/Graphics/Gloss/Internals/Interface/Backend/Types.hs0000644000000000000000000001424407346545000022737 0ustar0000000000000000 {-# OPTIONS -fspec-constr-count=5 #-} {-# LANGUAGE Rank2Types #-} module Graphics.Gloss.Internals.Interface.Backend.Types ( module Graphics.Gloss.Internals.Interface.Backend.Types , module Graphics.Gloss.Data.Display) where import Data.IORef import Graphics.Gloss.Data.Display -- | 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, Gloss 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; see the GLUT backend for an example. 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 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 Glosses 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) gloss-1.13.1.2/Graphics/Gloss/Internals/Interface/Callback.hs0000644000000000000000000000051307346545000021772 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -- | Re-export event callbacks. module Graphics.Gloss.Internals.Interface.Callback ( Callback(..) , DisplayCallback , KeyboardMouseCallback , MotionCallback , IdleCallback , ReshapeCallback) where import Graphics.Gloss.Internals.Interface.Backend.Types gloss-1.13.1.2/Graphics/Gloss/Internals/Interface/Common/0000755000000000000000000000000007346545000021173 5ustar0000000000000000gloss-1.13.1.2/Graphics/Gloss/Internals/Interface/Common/Exit.hs0000644000000000000000000000117207346545000022441 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# OPTIONS_HADDOCK hide #-} -- | Callback for exiting the program. module Graphics.Gloss.Internals.Interface.Common.Exit (callback_exit) where import Graphics.Gloss.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 () gloss-1.13.1.2/Graphics/Gloss/Internals/Interface/Debug.hs0000644000000000000000000000553007346545000021330 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -- | Implements functions to dump portions of the OpenGL state to stdout. -- Used for debugging. module Graphics.Gloss.Internals.Interface.Debug ( dumpFramebufferState , dumpFragmentState ) where import qualified Graphics.Rendering.OpenGL.GL as GL import Graphics.Rendering.OpenGL (get) -- | 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" gloss-1.13.1.2/Graphics/Gloss/Internals/Interface/Display.hs0000644000000000000000000000617407346545000021714 0ustar0000000000000000 module Graphics.Gloss.Internals.Interface.Display (displayWithBackend) where import Graphics.Gloss.Data.Color import Graphics.Gloss.Data.Controller import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.ViewPort import Graphics.Gloss.Data.ViewState import Graphics.Gloss.Rendering import Graphics.Gloss.Internals.Interface.Backend import Graphics.Gloss.Internals.Interface.Window import Graphics.Gloss.Internals.Interface.Common.Exit import Graphics.Gloss.Internals.Interface.ViewState.KeyMouse import Graphics.Gloss.Internals.Interface.ViewState.Motion import Graphics.Gloss.Internals.Interface.ViewState.Reshape import qualified Graphics.Gloss.Internals.Interface.Callback as Callback 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 } gloss-1.13.1.2/Graphics/Gloss/Internals/Interface/Event.hs0000644000000000000000000000272507346545000021366 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} module Graphics.Gloss.Internals.Interface.Event ( Event (..) , keyMouseEvent , motionEvent ) where import Data.IORef import Graphics.Gloss.Internals.Interface.Backend -- | 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' gloss-1.13.1.2/Graphics/Gloss/Internals/Interface/Game.hs0000644000000000000000000001373207346545000021156 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} module Graphics.Gloss.Internals.Interface.Game ( playWithBackendIO , Event(..) ) where import Graphics.Gloss.Data.Color import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.ViewPort import Graphics.Gloss.Rendering import Graphics.Gloss.Internals.Interface.Event import Graphics.Gloss.Internals.Interface.Backend import Graphics.Gloss.Internals.Interface.Window import Graphics.Gloss.Internals.Interface.Common.Exit import Graphics.Gloss.Internals.Interface.ViewState.Reshape import Graphics.Gloss.Internals.Interface.Animate.Timing import Graphics.Gloss.Internals.Interface.Simulate.Idle import qualified Graphics.Gloss.Internals.Interface.Callback as Callback import qualified Graphics.Gloss.Internals.Interface.Simulate.State as SM import qualified Graphics.Gloss.Internals.Interface.Animate.State as AN 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) gloss-1.13.1.2/Graphics/Gloss/Internals/Interface/Interact.hs0000644000000000000000000001244707346545000022060 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} module Graphics.Gloss.Internals.Interface.Interact (interactWithBackend) where import Graphics.Gloss.Data.Color import Graphics.Gloss.Data.Controller import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.ViewPort import Graphics.Gloss.Data.ViewState import Graphics.Gloss.Rendering import Graphics.Gloss.Internals.Interface.Event import Graphics.Gloss.Internals.Interface.Backend import Graphics.Gloss.Internals.Interface.Window import Graphics.Gloss.Internals.Interface.ViewState.Reshape import qualified Graphics.Gloss.Internals.Interface.Callback as Callback 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 gloss-1.13.1.2/Graphics/Gloss/Internals/Interface/Simulate.hs0000644000000000000000000001005007346545000022056 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} module Graphics.Gloss.Internals.Interface.Simulate (simulateWithBackendIO) where import Graphics.Gloss.Data.Display import Graphics.Gloss.Data.Color import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.ViewPort import Graphics.Gloss.Data.ViewState import Graphics.Gloss.Rendering import Graphics.Gloss.Internals.Interface.Backend import Graphics.Gloss.Internals.Interface.Window import Graphics.Gloss.Internals.Interface.Common.Exit import Graphics.Gloss.Internals.Interface.ViewState.KeyMouse import Graphics.Gloss.Internals.Interface.ViewState.Motion import Graphics.Gloss.Internals.Interface.ViewState.Reshape import Graphics.Gloss.Internals.Interface.Animate.Timing import Graphics.Gloss.Internals.Interface.Simulate.Idle import qualified Graphics.Gloss.Internals.Interface.Callback as Callback import qualified Graphics.Gloss.Internals.Interface.Simulate.State as SM import qualified Graphics.Gloss.Internals.Interface.Animate.State as AN 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 ())) gloss-1.13.1.2/Graphics/Gloss/Internals/Interface/Simulate/0000755000000000000000000000000007346545000021526 5ustar0000000000000000gloss-1.13.1.2/Graphics/Gloss/Internals/Interface/Simulate/Idle.hs0000644000000000000000000001063007346545000022737 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE RankNTypes #-} module Graphics.Gloss.Internals.Interface.Simulate.Idle ( callback_simulate_idle ) where import Graphics.Gloss.Data.ViewPort import Graphics.Gloss.Internals.Interface.Callback import qualified Graphics.Gloss.Internals.Interface.Backend as Backend import qualified Graphics.Gloss.Internals.Interface.Animate.State as AN import qualified Graphics.Gloss.Internals.Interface.Simulate.State as SM import Data.IORef import Control.Monad 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 glut 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 gloss-1.13.1.2/Graphics/Gloss/Internals/Interface/Simulate/State.hs0000644000000000000000000000135107346545000023142 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} module Graphics.Gloss.Internals.Interface.Simulate.State ( State (..) , stateInit ) where -- | Simulation state data State = State { -- | The iteration number we're up to. stateIteration :: !Integer -- | How many simulation setps to take for each second of real time , stateResolution :: !Int -- | How many seconds worth of simulation we've done so far , stateSimTime :: !Float } -- | Initial control state stateInit :: Int -> State stateInit resolution = State { stateIteration = 0 , stateResolution = resolution , stateSimTime = 0 } gloss-1.13.1.2/Graphics/Gloss/Internals/Interface/ViewState/0000755000000000000000000000000007346545000021656 5ustar0000000000000000gloss-1.13.1.2/Graphics/Gloss/Internals/Interface/ViewState/KeyMouse.hs0000644000000000000000000000205307346545000023753 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE RankNTypes #-} module Graphics.Gloss.Internals.Interface.ViewState.KeyMouse (callback_viewState_keyMouse) where import Graphics.Gloss.Data.ViewState import Graphics.Gloss.Internals.Interface.Backend import Graphics.Gloss.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 gloss-1.13.1.2/Graphics/Gloss/Internals/Interface/ViewState/Motion.hs0000644000000000000000000000207507346545000023463 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_HADDOCK hide #-} module Graphics.Gloss.Internals.Interface.ViewState.Motion (callback_viewState_motion) where import Graphics.Gloss.Data.ViewState import Graphics.Gloss.Internals.Interface.Callback import Graphics.Gloss.Internals.Interface.Backend import Graphics.Gloss.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 gloss-1.13.1.2/Graphics/Gloss/Internals/Interface/ViewState/Reshape.hs0000644000000000000000000000172507346545000023606 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} module Graphics.Gloss.Internals.Interface.ViewState.Reshape (callback_viewState_reshape, viewState_reshape) where import Graphics.Gloss.Internals.Interface.Callback import Graphics.Gloss.Internals.Interface.Backend import Graphics.Rendering.OpenGL (($=)) import qualified Graphics.Rendering.OpenGL.GL 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 gloss-1.13.1.2/Graphics/Gloss/Internals/Interface/Window.hs0000644000000000000000000000467407346545000021561 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -- | The main display function. module Graphics.Gloss.Internals.Interface.Window ( createWindow ) where import Graphics.Gloss.Data.Color import Graphics.Gloss.Internals.Color import Graphics.Gloss.Internals.Interface.Backend import Graphics.Gloss.Internals.Interface.Debug import Graphics.Rendering.OpenGL (($=)) import qualified Graphics.Rendering.OpenGL.GL as GL import Data.IORef (IORef, newIORef) import Control.Monad -- | 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" gloss-1.13.1.2/LICENSE0000644000000000000000000000115607346545000012265 0ustar0000000000000000Copyright (c) 2010-2016 The Gloss 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 condition: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. gloss-1.13.1.2/Setup.hs0000644000000000000000000000005607346545000012712 0ustar0000000000000000import Distribution.Simple main = defaultMain gloss-1.13.1.2/gloss.cabal0000644000000000000000000001001007346545000013360 0ustar0000000000000000Name: gloss Version: 1.13.1.2 License: MIT License-file: LICENSE Author: Ben Lippmeier Maintainer: benl@ouroborus.net Build-Type: Simple Cabal-Version: >=1.10 Stability: stable Category: Graphics Homepage: http://gloss.ouroborus.net Bug-reports: gloss@ouroborus.net Description: Gloss hides the pain of drawing simple vector graphics behind a nice data type and a few display functions. Gloss uses 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. source-repository head type: git location: https://github.com/benl23x5/gloss source-repository this type: git tag: v1.13.0.0 location: https://github.com/benl23x5/gloss Flag GLUT Description: Enable the GLUT backend Default: True Flag GLFW Description: Enable the GLFW backend Default: False Flag ExplicitBackend Description: Expose versions of 'display' and friends that allow you to choose what window manager backend to use. Default: False Library Build-Depends: base >= 4.8 && < 5 , bmp == 1.2.* , bytestring == 0.10.* , containers >= 0.5 && < 0.7 , ghc-prim , gloss-rendering == 1.13.* , GLUT == 2.7.* , OpenGL >= 2.12 && < 3.1 ghc-options: -O2 -Wall Default-Language: Haskell2010 Exposed-modules: Graphics.Gloss Graphics.Gloss.Data.Bitmap Graphics.Gloss.Data.Color Graphics.Gloss.Data.Controller Graphics.Gloss.Data.Display Graphics.Gloss.Data.Picture Graphics.Gloss.Data.Point Graphics.Gloss.Data.Point.Arithmetic Graphics.Gloss.Data.Vector Graphics.Gloss.Data.ViewPort Graphics.Gloss.Data.ViewState Graphics.Gloss.Geometry.Angle Graphics.Gloss.Geometry.Line Graphics.Gloss.Interface.Pure.Display Graphics.Gloss.Interface.Pure.Animate Graphics.Gloss.Interface.Pure.Simulate Graphics.Gloss.Interface.Pure.Game Graphics.Gloss.Interface.IO.Animate Graphics.Gloss.Interface.IO.Display Graphics.Gloss.Interface.IO.Interact Graphics.Gloss.Interface.IO.Simulate Graphics.Gloss.Interface.IO.Game Graphics.Gloss.Interface.Environment Other-modules: Graphics.Gloss.Internals.Color Graphics.Gloss.Internals.Interface.Animate.State Graphics.Gloss.Internals.Interface.Animate.Timing Graphics.Gloss.Internals.Interface.Backend.Types Graphics.Gloss.Internals.Interface.Callback Graphics.Gloss.Internals.Interface.Common.Exit Graphics.Gloss.Internals.Interface.Debug Graphics.Gloss.Internals.Interface.Event Graphics.Gloss.Internals.Interface.Simulate.Idle Graphics.Gloss.Internals.Interface.Simulate.State Graphics.Gloss.Internals.Interface.ViewState.KeyMouse Graphics.Gloss.Internals.Interface.ViewState.Motion Graphics.Gloss.Internals.Interface.ViewState.Reshape Graphics.Gloss.Internals.Interface.Window Graphics.Gloss.Internals.Interface.Display Graphics.Gloss.Internals.Interface.Animate Graphics.Gloss.Internals.Interface.Interact Graphics.Gloss.Internals.Interface.Simulate Graphics.Gloss.Internals.Interface.Game Graphics.Gloss.Internals.Interface.Backend If flag(GLUT) CPP-Options: -DWITHGLUT Other-modules: Graphics.Gloss.Internals.Interface.Backend.GLUT If flag(GLFW) Build-Depends: GLFW-b >= 1.4.1.0 && < 2 CPP-Options: -DWITHGLFW Other-modules: Graphics.Gloss.Internals.Interface.Backend.GLFW -- vim: nospell