gloss-1.9.3.1/0000755000000000000000000000000012510416745011205 5ustar0000000000000000gloss-1.9.3.1/gloss.cabal0000644000000000000000000000674612510416745013335 0ustar0000000000000000Name: gloss Version: 1.9.3.1 License: MIT License-file: LICENSE Author: Ben Lippmeier Maintainer: benl@ouroborus.net Build-Type: Simple Cabal-Version: >=1.6 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 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.*, ghc-prim == 0.4.*, containers == 0.5.*, bytestring == 0.10.*, OpenGL == 2.12.*, GLUT == 2.7.*, bmp == 1.2.*, gloss-rendering == 1.9.3.* ghc-options: -O2 -Wall Exposed-modules: Graphics.Gloss Graphics.Gloss.Data.Bitmap Graphics.Gloss.Data.Color Graphics.Gloss.Data.Display Graphics.Gloss.Data.Picture Graphics.Gloss.Data.Point 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.Simulate Graphics.Gloss.Interface.IO.Game 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.Simulate Graphics.Gloss.Internals.Interface.Game Graphics.Gloss.Internals.Interface.Backend Extensions: DeriveDataTypeable PatternGuards If flag(GLUT) CPP-Options: -DWITHGLUT Other-modules: Graphics.Gloss.Internals.Interface.Backend.GLUT If flag(GLFW) Build-Depends: GLFW-b >= 0.1.4.1 && < 0.2 CPP-Options: -DWITHGLFW Other-modules: Graphics.Gloss.Internals.Interface.Backend.GLFW gloss-1.9.3.1/LICENSE0000644000000000000000000000114712510416745012215 0ustar0000000000000000Copyright (c) 2010-2014 Benjamin Lippmeier 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.9.3.1/Setup.hs0000644000000000000000000000005612510416745012642 0ustar0000000000000000import Distribution.Simple main = defaultMain gloss-1.9.3.1/Graphics/0000755000000000000000000000000012510416745012745 5ustar0000000000000000gloss-1.9.3.1/Graphics/Gloss.hs0000644000000000000000000000510612510416745014372 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 - left-click drag, arrow keys. -- -- * Rotate Viewport - right-click drag, control-left-click drag, or home\/end-keys. -- -- * Zoom Viewport - mouse wheel, or page up\/down-keys. -- -- 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.9: -- Thanks to Elise Huard -- * Split rendering code into gloss-rendering package. -- -- For 1.8 -- Thanks to Francesco Mazzoli -- * Factored out ViewPort and ViewState handling into user visible modules. -- -- For 1.7: -- * Tweaked circle level-of-detail reduction code. -- * Increased frame rate cap to 100hz. -- Thanks to Doug Burke -- * Primitives for drawing arcs and sectors. -- Thanks to Thomas DuBuisson -- * IO versions of animate, simulate and play. -- -- For 1.6: -- Thanks to Anthony Cowley -- * Full screen display mode. -- -- For 1.5: -- * O(1) Conversion of ForeignPtrs to bitmaps. -- * An extra flag on the Bitmap constructor allows bitmaps to be cached -- in texture memory between frames. -- @ -- -- 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.9.3.1/Graphics/Gloss/0000755000000000000000000000000012510416745014034 5ustar0000000000000000gloss-1.9.3.1/Graphics/Gloss/Data/0000755000000000000000000000000012510416745014705 5ustar0000000000000000gloss-1.9.3.1/Graphics/Gloss/Data/Bitmap.hs0000644000000000000000000000037212510416745016457 0ustar0000000000000000 -- | Functions to load bitmap data from various places. module Graphics.Gloss.Data.Bitmap ( BitmapData , bitmapOfForeignPtr , bitmapOfByteString , bitmapOfBMP , loadBMP) where import Graphics.Gloss.Rendering gloss-1.9.3.1/Graphics/Gloss/Data/Color.hs0000644000000000000000000000741212510416745016323 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 -- ** 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 -- | Normalise a color to the value of its largest RGB component. normalizeColor :: Color -> Color normalizeColor cc = let (r, g, b, a) = rgbaOfColor cc m = maximum [r, g, b] in makeColor (r / m) (g / m) (b / m) a -- Color functions ------------------------------------------------------------ -- | Mix two colors with the given ratios. mixColors :: Float -- ^ Ratio of first color. -> Float -- ^ Ratio of second color. -> Color -- ^ First color. -> Color -- ^ Second color. -> Color -- ^ Resulting color. mixColors ratio1 ratio2 c1 c2 = let (r1, g1, b1, a1) = rgbaOfColor c1 (r2, g2, b2, a2) = rgbaOfColor c2 total = ratio1 + ratio2 m1 = ratio1 / total m2 = ratio2 / total in makeColor (m1 * r1 + m2 * r2) (m1 * g1 + m2 * g2) (m1 * b1 + m2 * b2) (m1 * a1 + m2 * a2) -- | 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 $ makeColor (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 -- Pre-defined Colors --------------------------------------------------------- -- | A greyness of a given order. greyN :: Float -- ^ Range is 0 = black, to 1 = white. -> 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 gloss-1.9.3.1/Graphics/Gloss/Data/Display.hs0000644000000000000000000000061112510416745016644 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 with a drawing area of the given size. | FullScreen (Int, Int) deriving (Eq, Read, Show) gloss-1.9.3.1/Graphics/Gloss/Data/Picture.hs0000644000000000000000000001307612510416745016663 0ustar0000000000000000 module Graphics.Gloss.Data.Picture ( Picture (..) , Point, Vector, Path -- * Aliases for Picture constructors , blank , polygon , line , circle, thickCircle , arc, thickArc , text , 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 with a width, height and a Vector holding the -- 32-bit RGBA bitmap data. -- -- The boolean flag controls whether Gloss should cache the data -- between frames for speed. -- If you are programatically generating the image for -- each frame then use `False`. -- If you have loaded it from a file then use `True`. bitmap :: Int -> Int -> BitmapData -> Bool -> Picture bitmap = Bitmap -- | 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.9.3.1/Graphics/Gloss/Data/Point.hs0000644000000000000000000000140012510416745016325 0ustar0000000000000000{-# OPTIONS -fno-warn-missing-methods -fno-warn-orphans #-} {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} module 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.9.3.1/Graphics/Gloss/Data/Vector.hs0000644000000000000000000000374112510416745016510 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.9.3.1/Graphics/Gloss/Data/ViewPort.hs0000644000000000000000000000440212510416745017020 0ustar0000000000000000 module Graphics.Gloss.Data.ViewPort ( ViewPort(..) , viewPortInit , applyViewPortToPicture , invertViewPort ) where import Graphics.Gloss.Data.Picture -- | 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) - vtrans -- | Convert degrees to radians {-# INLINE degToRad #-} degToRad :: Float -> Float degToRad d = d * pi / 180 -- | 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.9.3.1/Graphics/Gloss/Data/ViewState.hs0000644000000000000000000002576712510416745017175 0ustar0000000000000000module 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) -- | The commands suported by the view controller. data Command = CRestore | CTranslate | CRotate -- 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 })) ]) , (CRotate, [ ( MouseButton RightButton , Nothing) , ( MouseButton LeftButton , 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 -- | During viewport translation, -- where the mouse was clicked on the window. , viewStateTranslateMark :: !(Maybe (Float, Float)) -- | During viewport rotation, -- where the mouse was clicked on the window , viewStateRotateMark :: !(Maybe (Float, Float)) , 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 , viewStateTranslateMark = Nothing , viewStateRotateMark = 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 } } | isCommand commands CTranslate key keyMods , keyState == Down , not currentlyRotating = Just $ viewState { viewStateTranslateMark = Just pos } -- We don't want to use 'isCommand' here because the user may have -- released the translation modifier key before the mouse button. -- and we still want to cancel the translation. | currentlyTranslating , keyState == Up = Just $ viewState { viewStateTranslateMark = Nothing } | isCommand commands CRotate key keyMods , keyState == Down , not currentlyTranslating = Just $ viewState { viewStateRotateMark = Just pos } -- We don't want to use 'isCommand' here because the user may have -- released the rotation modifier key before the mouse button, -- and we still want to cancel the rotation. | currentlyRotating , keyState == Up = Just $ viewState { viewStateRotateMark = Nothing } | otherwise = Nothing where commands = viewStateCommands viewState port = viewStateViewPort viewState currentlyTranslating = isJust $ viewStateTranslateMark viewState currentlyRotating = isJust $ viewStateRotateMark viewState -- Note that only a translation or rotation applies, not both at the same time. updateViewStateWithEventMaybe (EventMotion pos) viewState = 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 - o } where offset = (bumpX / scale, bumpY / scale) o = rotateV (degToRad r) offset -- | Apply a translation to the `ViewState`. motionTranslate :: Maybe (Float, Float) -> (Float, Float) -> ViewState -> Maybe ViewState motionTranslate Nothing _ _ = Nothing motionTranslate (Just (markX, markY)) (posX, posY) viewState = Just $ viewState { viewStateViewPort = port { viewPortTranslate = trans - 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) -> (Float, Float) -> 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 gloss-1.9.3.1/Graphics/Gloss/Geometry/0000755000000000000000000000000012510416745015627 5ustar0000000000000000gloss-1.9.3.1/Graphics/Gloss/Geometry/Angle.hs0000644000000000000000000000127012510416745017211 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.9.3.1/Graphics/Gloss/Geometry/Line.hs0000644000000000000000000002171112510416745017054 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 -- | 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 + (u `mulSV` (p2 - 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 - p1) `dotV` (p2 - p1) / (p2 - p1) `dotV` (p2 - 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.9.3.1/Graphics/Gloss/Interface/0000755000000000000000000000000012510416745015734 5ustar0000000000000000gloss-1.9.3.1/Graphics/Gloss/Interface/IO/0000755000000000000000000000000012510416745016243 5ustar0000000000000000gloss-1.9.3.1/Graphics/Gloss/Interface/IO/Animate.hs0000644000000000000000000000335712510416745020165 0ustar0000000000000000 -- | Display mode is for drawing a static picture. module Graphics.Gloss.Interface.IO.Animate ( module Graphics.Gloss.Data.Display , module Graphics.Gloss.Data.Picture , module Graphics.Gloss.Data.Color , animateIO , animateFixedIO) 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@. -- 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. -> IO () animateIO display backColor frameFunIO = animateWithBackendIO defaultBackendState True -- pannable display backColor frameFunIO -- | 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. -> IO () animateFixedIO display backColor frameFunIO = animateWithBackendIO defaultBackendState False display backColor frameFunIO gloss-1.9.3.1/Graphics/Gloss/Interface/IO/Game.hs0000644000000000000000000000331712510416745017454 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 `displayInWindow`. 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.9.3.1/Graphics/Gloss/Interface/IO/Simulate.hs0000644000000000000000000000302012510416745020355 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.9.3.1/Graphics/Gloss/Interface/Pure/0000755000000000000000000000000012510416745016647 5ustar0000000000000000gloss-1.9.3.1/Graphics/Gloss/Interface/Pure/Animate.hs0000644000000000000000000000215112510416745020560 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) gloss-1.9.3.1/Graphics/Gloss/Interface/Pure/Display.hs0000644000000000000000000000201012510416745020601 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. -- -- Use the following commands once the window is open: -- -- * Quit - esc-key. -- * Move Viewport - left-click drag, arrow keys. -- * Rotate Viewport - right-click drag, control-left-click drag, or home\/end-keys. -- * Zoom Viewport - mouse wheel, or page up\/down-keys. -- display :: Display -- ^ Display mode. -> Color -- ^ Background color. -> Picture -- ^ The picture to draw. -> IO () display = displayWithBackend defaultBackendState gloss-1.9.3.1/Graphics/Gloss/Interface/Pure/Game.hs0000644000000000000000000000360112510416745020054 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 = playWithBackendIO defaultBackendState display backColor simResolution worldStart (return . worldToPicture) (\event world -> return $ worldHandleEvent event world) (\time world -> return $ worldAdvance time world) True gloss-1.9.3.1/Graphics/Gloss/Interface/Pure/Simulate.hs0000644000000000000000000000376112510416745020775 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 = simulateWithBackendIO defaultBackendState display backColor simResolution modelStart (return . modelToPicture) (\view time model -> return $ modelStep view time model) gloss-1.9.3.1/Graphics/Gloss/Internals/0000755000000000000000000000000012510416745015773 5ustar0000000000000000gloss-1.9.3.1/Graphics/Gloss/Internals/Color.hs0000644000000000000000000000110612510416745017403 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 :: Fractional a => 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.9.3.1/Graphics/Gloss/Internals/Interface/0000755000000000000000000000000012510416745017673 5ustar0000000000000000gloss-1.9.3.1/Graphics/Gloss/Internals/Interface/Animate.hs0000644000000000000000000000623512510416745021613 0ustar0000000000000000 module Graphics.Gloss.Internals.Interface.Animate (animateWithBackendIO) where 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 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. -> IO () animateWithBackendIO backend pannable display backColor frameOp = 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 getsIORef :: IORef a -> (a -> r) -> IO r getsIORef ref fun = liftM fun $ readIORef ref gloss-1.9.3.1/Graphics/Gloss/Internals/Interface/Backend.hs0000644000000000000000000000167612510416745021570 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.9.3.1/Graphics/Gloss/Internals/Interface/Callback.hs0000644000000000000000000000051312510416745021722 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.9.3.1/Graphics/Gloss/Internals/Interface/Debug.hs0000644000000000000000000000563012510416745021261 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.9.3.1/Graphics/Gloss/Internals/Interface/Display.hs0000644000000000000000000000416512510416745021642 0ustar0000000000000000 module Graphics.Gloss.Internals.Interface.Display (displayWithBackend) where 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 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. -> Picture -- ^ The picture to draw. -> IO () displayWithBackend backend displayMode background picture = do viewSR <- newIORef viewStateInit renderS <- initState renderSR <- newIORef renderS let renderFun backendRef = do port <- viewStateViewPort <$> readIORef viewSR options <- readIORef renderSR windowSize <- getWindowDimensions backendRef 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 ] createWindow backend displayMode background callbacks gloss-1.9.3.1/Graphics/Gloss/Internals/Interface/Event.hs0000644000000000000000000000273512510416745021317 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.9.3.1/Graphics/Gloss/Internals/Interface/Game.hs0000644000000000000000000001361612510416745021107 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 -- | 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.9.3.1/Graphics/Gloss/Internals/Interface/Simulate.hs0000644000000000000000000001000612510416745022007 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 gloss-1.9.3.1/Graphics/Gloss/Internals/Interface/Window.hs0000644000000000000000000000440212510416745021476 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 (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 -> IO () createWindow backend display clearColor callbacks = 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 when debug $ do putStr $ "* entering mainloop..\n" -- Start the main backend loop runMainLoop backendStateRef when debug $ putStr $ "* all done\n" return () gloss-1.9.3.1/Graphics/Gloss/Internals/Interface/Animate/0000755000000000000000000000000012510416745021251 5ustar0000000000000000gloss-1.9.3.1/Graphics/Gloss/Internals/Interface/Animate/State.hs0000644000000000000000000000364212510416745022672 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.9.3.1/Graphics/Gloss/Internals/Interface/Animate/Timing.hs0000644000000000000000000000641712510416745023044 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 stateRef `modifyIORef` \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) $ stateRef `modifyIORef` \s -> s { stateAnimateTime = animateTime + displayTimeElapsed } when animate $ stateRef `modifyIORef` \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 gateTimeStart <- elapsedTime backendRef -- the start of this gate gateTimeEnd <- stateRef `getsIORef` stateGateTimeEnd -- end of the previous gate let gateTimeElapsed = gateTimeStart - gateTimeEnd when (gateTimeElapsed < timeClamp) $ do sleep backendRef (timeClamp - gateTimeElapsed) gateTimeFinal <- elapsedTime backendRef stateRef `modifyIORef` \s -> s { stateGateTimeEnd = gateTimeFinal , stateGateTimeElapsed = gateTimeElapsed } getsIORef :: IORef a -> (a -> r) -> IO r getsIORef ref fun = liftM fun $ readIORef ref gloss-1.9.3.1/Graphics/Gloss/Internals/Interface/Backend/0000755000000000000000000000000012510416745021222 5ustar0000000000000000gloss-1.9.3.1/Graphics/Gloss/Internals/Interface/Backend/GLFW.hs0000644000000000000000000005061712510416745022326 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 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 () } -- | 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 = (\_ -> GLFW.getWindowDimensions) elapsedTime = (\_ -> GLFW.getTime) sleep = (\_ sec -> GLFW.sleep sec) -- Initialise ----------------------------------------------------------------- -- | Initialise the GLFW backend. initializeGLFW :: IORef GLFWState -> Bool-> IO () initializeGLFW _ debug = do _ <- GLFW.initialize glfwVersion <- GLFW.getGlfwVersion #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 _ = do #ifdef linux_HOST_OS -- See [Note: FreeGlut] on why we exit GLUT for Linux GLUT.exit #endif GLFW.closeWindow -- Open Window ---------------------------------------------------------------- -- | Open a new window. openWindowGLFW :: IORef GLFWState -> Display -> IO () openWindowGLFW _ (InWindow title (sizeX, sizeY) pos) = do _ <- GLFW.openWindow GLFW.defaultDisplayOptions { GLFW.displayOptions_width = sizeX , GLFW.displayOptions_height = sizeY , GLFW.displayOptions_displayMode = GLFW.Window } uncurry GLFW.setWindowPosition pos GLFW.setWindowTitle title -- Try to enable sync-to-vertical-refresh by setting the number -- of buffer swaps per vertical refresh to 1. GLFW.setWindowBufferSwapInterval 1 openWindowGLFW _ (FullScreen (sizeX, sizeY)) = do _ <- GLFW.openWindow GLFW.defaultDisplayOptions { GLFW.displayOptions_width = sizeX , GLFW.displayOptions_height = sizeY , GLFW.displayOptions_displayMode = GLFW.Fullscreen } -- Try to enable sync-to-vertical-refresh by setting the number -- of buffer swaps per vertical refresh to 1. GLFW.setWindowBufferSwapInterval 1 GLFW.enableMouseCursor -- Dump State ----------------------------------------------------------------- -- | Print out the internal GLFW state. dumpStateGLFW :: IORef a -> IO () dumpStateGLFW _ = do (ww,wh) <- GLFW.getWindowDimensions r <- GLFW.getWindowValue NumRedBits g <- GLFW.getWindowValue NumGreenBits b <- GLFW.getWindowValue NumBlueBits a <- GLFW.getWindowValue NumAlphaBits let rgbaBD = [r,g,b,a] depthBD <- GLFW.getWindowValue NumDepthBits ra <- GLFW.getWindowValue NumAccumRedBits ga <- GLFW.getWindowValue NumAccumGreenBits ba <- GLFW.getWindowValue NumAccumBlueBits aa <- GLFW.getWindowValue NumAccumAlphaBits let accumBD = [ra,ga,ba,aa] stencilBD <- GLFW.getWindowValue NumStencilBits auxBuffers <- GLFW.getWindowValue NumAuxBuffers fsaaSamples <- GLFW.getWindowValue 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" -- 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 _ = GLFW.setWindowCloseCallback $ do #ifdef linux_HOST_OS -- See [Note: FreeGlut] for why we need this. GLUT.exit #endif return True -- Reshape -------------------------------------------------------------------- -- | Callback for when the user reshapes the window. installReshapeCallbackGLFW :: Backend a => IORef a -> [Callback] -> IO () installReshapeCallbackGLFW stateRef callbacks = GLFW.setWindowSizeCallback (callbackReshape stateRef callbacks) callbackReshape :: Backend a => IORef a -> [Callback] -> Int -> Int -> IO () callbackReshape glfwState callbacks 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 GLFW.setKeyCallback $ (callbackKeyboard stateRef callbacks) GLFW.setCharCallback $ (callbackChar stateRef callbacks) GLFW.setMouseButtonCallback $ (callbackMouseButton stateRef callbacks) GLFW.setMouseWheelCallback $ (callbackMouseWheel stateRef callbacks) -- GLFW calls this on a non-character keyboard action. callbackKeyboard :: IORef GLFWState -> [Callback] -> GLFW.Key -> Bool -> IO () callbackKeyboard stateRef callbacks key keystate = do (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.KeyLeftShift -> mods {shift = if pressed then Down else Up} GLFW.KeyLeftCtrl -> mods {ctrl = if pressed then Down else Up} GLFW.KeyLeftAlt -> 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] -> Char -> Bool -> IO () callbackChar stateRef callbacks char keystate = do (GLFWState mods pos _ _ _ _) <- readIORef stateRef let key' = charToSpecial char -- 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.MouseButton -> Bool -> IO () callbackMouseButton stateRef callbacks key keystate = do (GLFWState mods pos _ _ _ _) <- readIORef stateRef let key' = fromGLFW key 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 moves the mouse wheel. callbackMouseWheel :: IORef GLFWState -> [Callback] -> Int -> IO () callbackMouseWheel stateRef callbacks w = do (key, keystate) <- setMouseWheel stateRef w (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 = GLFW.setMousePositionCallback $ (callbackMotion stateRef callbacks) callbackMotion :: IORef GLFWState -> [Callback] -> Int -> Int -> IO () callbackMotion stateRef callbacks x y = do pos <- setMousePos stateRef x 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 windowIsOpen <- GLFW.windowIsOpen when windowIsOpen $ do GLFW.pollEvents dirty <- fmap dirtyScreen $ readIORef stateRef when dirty $ do s <- readIORef stateRef display s GLFW.swapBuffers modifyIORef stateRef $ \s -> s { dirtyScreen = False } (readIORef stateRef) >>= (\s -> idle s) GLFW.sleep 0.001 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.CharKey c -> charToSpecial (toLower c) GLFW.KeySpace -> SpecialKey KeySpace GLFW.KeyEsc -> SpecialKey KeyEsc GLFW.KeyF1 -> SpecialKey KeyF1 GLFW.KeyF2 -> SpecialKey KeyF2 GLFW.KeyF3 -> SpecialKey KeyF3 GLFW.KeyF4 -> SpecialKey KeyF4 GLFW.KeyF5 -> SpecialKey KeyF5 GLFW.KeyF6 -> SpecialKey KeyF6 GLFW.KeyF7 -> SpecialKey KeyF7 GLFW.KeyF8 -> SpecialKey KeyF8 GLFW.KeyF9 -> SpecialKey KeyF9 GLFW.KeyF10 -> SpecialKey KeyF10 GLFW.KeyF11 -> SpecialKey KeyF11 GLFW.KeyF12 -> SpecialKey KeyF12 GLFW.KeyF13 -> SpecialKey KeyF13 GLFW.KeyF14 -> SpecialKey KeyF14 GLFW.KeyF15 -> SpecialKey KeyF15 GLFW.KeyF16 -> SpecialKey KeyF16 GLFW.KeyF17 -> SpecialKey KeyF17 GLFW.KeyF18 -> SpecialKey KeyF18 GLFW.KeyF19 -> SpecialKey KeyF19 GLFW.KeyF20 -> SpecialKey KeyF20 GLFW.KeyF21 -> SpecialKey KeyF21 GLFW.KeyF22 -> SpecialKey KeyF22 GLFW.KeyF23 -> SpecialKey KeyF23 GLFW.KeyF24 -> SpecialKey KeyF24 GLFW.KeyF25 -> SpecialKey KeyF25 GLFW.KeyUp -> SpecialKey KeyUp GLFW.KeyDown -> SpecialKey KeyDown GLFW.KeyLeft -> SpecialKey KeyLeft GLFW.KeyRight -> SpecialKey KeyRight GLFW.KeyTab -> SpecialKey KeyTab GLFW.KeyEnter -> SpecialKey KeyEnter GLFW.KeyBackspace -> SpecialKey KeyBackspace GLFW.KeyInsert -> SpecialKey KeyInsert GLFW.KeyDel -> SpecialKey KeyDelete GLFW.KeyPageup -> SpecialKey KeyPageUp GLFW.KeyPagedown -> SpecialKey KeyPageDown GLFW.KeyHome -> SpecialKey KeyHome GLFW.KeyEnd -> SpecialKey KeyEnd GLFW.KeyPad0 -> SpecialKey KeyPad0 GLFW.KeyPad1 -> SpecialKey KeyPad1 GLFW.KeyPad2 -> SpecialKey KeyPad2 GLFW.KeyPad3 -> SpecialKey KeyPad3 GLFW.KeyPad4 -> SpecialKey KeyPad4 GLFW.KeyPad5 -> SpecialKey KeyPad5 GLFW.KeyPad6 -> SpecialKey KeyPad6 GLFW.KeyPad7 -> SpecialKey KeyPad7 GLFW.KeyPad8 -> SpecialKey KeyPad8 GLFW.KeyPad9 -> SpecialKey KeyPad9 GLFW.KeyPadDivide -> SpecialKey KeyPadDivide GLFW.KeyPadMultiply -> SpecialKey KeyPadMultiply GLFW.KeyPadSubtract -> SpecialKey KeyPadSubtract GLFW.KeyPadAdd -> SpecialKey KeyPadAdd GLFW.KeyPadDecimal -> SpecialKey KeyPadDecimal GLFW.KeyPadEqual -> Char '=' GLFW.KeyPadEnter -> 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.MouseButton0 -> MouseButton LeftButton GLFW.MouseButton1 -> MouseButton RightButton GLFW.MouseButton2 -> MouseButton MiddleButton GLFW.MouseButton3 -> MouseButton $ AdditionalButton 3 GLFW.MouseButton4 -> MouseButton $ AdditionalButton 4 GLFW.MouseButton5 -> MouseButton $ AdditionalButton 5 GLFW.MouseButton6 -> MouseButton $ AdditionalButton 6 GLFW.MouseButton7 -> MouseButton $ AdditionalButton 7 gloss-1.9.3.1/Graphics/Gloss/Internals/Interface/Backend/GLUT.hs0000644000000000000000000003214412510416745022335 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} module Graphics.Gloss.Internals.Interface.Backend.GLUT (GLUTState) 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 -- | We don't maintain any state information for the GLUT backend, -- so this data type is empty. data GLUTState = GLUTState glutStateInit :: GLUTState glutStateInit = GLUTState 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 (_progName, _args) <- GLUT.getArgsAndInitialize glutVersion <- get GLUT.glutVersion when debug $ putStr $ " glutVersion = " ++ show glutVersion ++ "\n" GLUT.initialDisplayMode $= [ GLUT.RGBMode , GLUT.DoubleBuffered] -- 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" -- 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 (sizeX, sizeY) -> do GLUT.gameModeCapabilities $= [ GLUT.Where' GLUT.GameModeWidth GLUT.IsEqualTo sizeX , GLUT.Where' GLUT.GameModeHeight GLUT.IsEqualTo sizeY ] void $ GLUT.enterGameMode -- 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 ref 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 ref | (Display f) <- callbacks] sequence_ funs -- swap front and back buffers GLUT.swapBuffers -- Don't report errors by default. -- The windows OpenGL implementation seems to complain for no reason. -- GLUT.reportErrors return () -- 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 ref callbacks = GLUT.idleCallback $= Just (callbackIdle ref callbacks) 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.9.3.1/Graphics/Gloss/Internals/Interface/Backend/Types.hs0000644000000000000000000001365612510416745022675 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 ------------------------------------------------------------------------------- -- 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.9.3.1/Graphics/Gloss/Internals/Interface/Common/0000755000000000000000000000000012510416745021123 5ustar0000000000000000gloss-1.9.3.1/Graphics/Gloss/Internals/Interface/Common/Exit.hs0000644000000000000000000000116712510416745022375 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE PatternGuards, RankNTypes #-} -- | 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.9.3.1/Graphics/Gloss/Internals/Interface/Simulate/0000755000000000000000000000000012510416745021456 5ustar0000000000000000gloss-1.9.3.1/Graphics/Gloss/Internals/Interface/Simulate/Idle.hs0000644000000000000000000001074112510416745022672 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 simSR `modifyIORef` \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.9.3.1/Graphics/Gloss/Internals/Interface/Simulate/State.hs0000644000000000000000000000142112510416745023070 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.9.3.1/Graphics/Gloss/Internals/Interface/ViewState/0000755000000000000000000000000012510416745021606 5ustar0000000000000000gloss-1.9.3.1/Graphics/Gloss/Internals/Interface/ViewState/KeyMouse.hs0000644000000000000000000000205512510416745023705 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.9.3.1/Graphics/Gloss/Internals/Interface/ViewState/Motion.hs0000644000000000000000000000204612510416745023411 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE ScopedTypeVariables, RankNTypes #-} 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.9.3.1/Graphics/Gloss/Internals/Interface/ViewState/Reshape.hs0000644000000000000000000000172512510416745023536 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