gloss-1.7.8.3/0000755000000000000000000000000012150532165011205 5ustar0000000000000000gloss-1.7.8.3/gloss.cabal0000644000000000000000000000736212150532165013330 0ustar0000000000000000Name: gloss Version: 1.7.8.3 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. 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.6.*, ghc-prim == 0.3.*, containers == 0.5.*, bytestring == 0.10.*, OpenGL == 2.8.*, GLUT == 2.4.*, bmp == 1.2.* ghc-options: -O2 -Wall Exposed-modules: Graphics.Gloss Graphics.Gloss.Geometry Graphics.Gloss.Geometry.Angle Graphics.Gloss.Geometry.Line Graphics.Gloss.Data.Display Graphics.Gloss.Data.Point Graphics.Gloss.Data.Vector Graphics.Gloss.Data.Quad Graphics.Gloss.Data.Extent Graphics.Gloss.Data.QuadTree Graphics.Gloss.Data.Color Graphics.Gloss.Data.Picture Graphics.Gloss.Algorithms.RayCast 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.Simulate.Idle Graphics.Gloss.Internals.Interface.Simulate.State Graphics.Gloss.Internals.Interface.ViewPort Graphics.Gloss.Internals.Interface.ViewPort.Command Graphics.Gloss.Internals.Interface.ViewPort.ControlState Graphics.Gloss.Internals.Interface.ViewPort.KeyMouse Graphics.Gloss.Internals.Interface.ViewPort.Motion Graphics.Gloss.Internals.Interface.ViewPort.Reshape Graphics.Gloss.Internals.Interface.Window Graphics.Gloss.Internals.Render.Bitmap Graphics.Gloss.Internals.Render.Circle Graphics.Gloss.Internals.Render.Common Graphics.Gloss.Internals.Render.State Graphics.Gloss.Internals.Render.Picture Graphics.Gloss.Internals.Render.ViewPort 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 If flag(GLUT) CPP-Options: -DWITHGLUT Other-modules: Graphics.Gloss.Internals.Interface.Backend.GLUT If flag(GLFW) Build-Depends: GLFW-b >= 0.1.0.1 && < 0.2 CPP-Options: -DWITHGLFW Other-modules: Graphics.Gloss.Internals.Interface.Backend.GLFW gloss-1.7.8.3/LICENSE0000644000000000000000000000114712150532165012215 0ustar0000000000000000Copyright (c) 2010-2012 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.7.8.3/Setup.hs0000644000000000000000000000005612150532165012642 0ustar0000000000000000import Distribution.Simple main = defaultMain gloss-1.7.8.3/Graphics/0000755000000000000000000000000012150532164012744 5ustar0000000000000000gloss-1.7.8.3/Graphics/Gloss.hs0000644000000000000000000000465012150532164014374 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. -- -- -- @Release Notes: -- -- For 1.7.0: -- * 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, simplate and play. -- -- For 1.6.0: -- Thanks to Anthony Cowley -- * Full screen display mode. -- -- For 1.5.0: -- * 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 1.4.0: -- Thanks to Christiaan Baaij: -- * Refactoring of Gloss internals to support multiple window manager backends. -- * Support for using GLFW as the window library instead of GLUT. -- GLUT is still the default, but to use GLFW install gloss with: -- cabal install gloss --flags=\"GLFW -GLUT\" -- @ -- -- For more information, check out . -- module Graphics.Gloss ( module Graphics.Gloss.Data.Picture , module Graphics.Gloss.Data.Color , Display(..) , display , animate , simulate , play) where import Graphics.Gloss.Data.Display import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.Color 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.7.8.3/Graphics/Gloss/0000755000000000000000000000000012150532164014033 5ustar0000000000000000gloss-1.7.8.3/Graphics/Gloss/Geometry.hs0000644000000000000000000000030212150532164016155 0ustar0000000000000000 module Graphics.Gloss.Geometry ( module Graphics.Gloss.Geometry.Angle , module Graphics.Gloss.Geometry.Line ) where import Graphics.Gloss.Geometry.Angle import Graphics.Gloss.Geometry.Line gloss-1.7.8.3/Graphics/Gloss/Algorithms/0000755000000000000000000000000012150532164016144 5ustar0000000000000000gloss-1.7.8.3/Graphics/Gloss/Algorithms/RayCast.hs0000644000000000000000000000524512150532164020054 0ustar0000000000000000{-# LANGUAGE PatternGuards, RankNTypes #-} -- | Various ray casting algorithms. module Graphics.Gloss.Algorithms.RayCast ( castSegIntoCellularQuadTree , traceSegIntoCellularQuadTree) where import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.Quad import Graphics.Gloss.Data.Extent import Graphics.Gloss.Data.QuadTree import Data.List import Data.Function -- | The quadtree contains cells of unit extent (NetHack style). -- Given a line segement (P1-P2) through the tree, get the cell -- closest to P1 that intersects the segment, if any. -- -- TODO: This currently uses a naive algorithm. It just calls -- `traceSegIntoCellularQuadTree` and sorts the results -- to get the one closest to P1. It'd be better to do a -- proper walk over the tree in the direction of the ray. -- castSegIntoCellularQuadTree :: forall a . Point -- ^ (P1) Starting point of seg. -> Point -- ^ (P2) Final point of seg. -> Extent -- ^ Extent convering the whole tree. -> QuadTree a -- ^ The tree. -> Maybe (Point, Extent, a) -- ^ Intersection point, extent of cell, value of cell (if any). castSegIntoCellularQuadTree p1 p2 extent tree | cells@(_:_) <- traceSegIntoCellularQuadTree p1 p2 extent tree , c : _ <- sortBy ((compareDistanceTo p1) `on` (\(a, _, _) -> a) ) cells = Just c | otherwise = Nothing compareDistanceTo :: Point -> Point -> Point -> Ordering compareDistanceTo p0 p1 p2 = let d1 = distance p0 p1 d2 = distance p0 p2 in compare d1 d2 distance :: Point -> Point -> Float distance (x1, y1) (x2, y2) = let xd = x2 - x1 yd = y2 - y1 in sqrt (xd * xd + yd * yd) -- | The quadtree contains cells of unit extent (NetHack style). -- Given a line segment (P1-P2) through the tree, return the list of cells -- that intersect the segment. -- traceSegIntoCellularQuadTree :: forall a . Point -- ^ (P1) Starting point of seg. -> Point -- ^ (P2) Final point of seg. -> Extent -- ^ Extent covering the whole tree. -> QuadTree a -- ^ The tree. -> [(Point, Extent, a)] -- ^ Intersection point, extent of cell, value of cell. traceSegIntoCellularQuadTree p1 p2 extent tree = case tree of TNil -> [] TLeaf a -> case intersectSegExtent p1 p2 extent of Just pos -> [(pos, extent, a)] Nothing -> [] TNode nw ne sw se | touchesSegExtent p1 p2 extent -> concat [ traceSegIntoCellularQuadTree p1 p2 (cutQuadOfExtent NW extent) nw , traceSegIntoCellularQuadTree p1 p2 (cutQuadOfExtent NE extent) ne , traceSegIntoCellularQuadTree p1 p2 (cutQuadOfExtent SW extent) sw , traceSegIntoCellularQuadTree p1 p2 (cutQuadOfExtent SE extent) se ] _ -> [] gloss-1.7.8.3/Graphics/Gloss/Data/0000755000000000000000000000000012150532164014704 5ustar0000000000000000gloss-1.7.8.3/Graphics/Gloss/Data/Color.hs0000644000000000000000000001272712150532164016327 0ustar0000000000000000 -- | Predefined and custom colors. module Graphics.Gloss.Data.Color ( -- ** Color data type Color , makeColor , makeColor' , makeColor8 , rawColor , 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 -- | An abstract color value. -- We keep the type abstract so we can be sure that the components -- are in the required range. To make a custom color use 'makeColor'. data Color -- | Holds the color components. All components lie in the range [0..1. = RGBA !Float !Float !Float !Float deriving (Show, Eq) instance Num Color where {-# INLINE (+) #-} (+) (RGBA r1 g1 b1 _) (RGBA r2 g2 b2 _) = RGBA (r1 + r2) (g1 + g2) (b1 + b2) 1 {-# INLINE (-) #-} (-) (RGBA r1 g1 b1 _) (RGBA r2 g2 b2 _) = RGBA (r1 - r2) (g1 - g2) (b1 - b2) 1 {-# INLINE (*) #-} (*) (RGBA r1 g1 b1 _) (RGBA r2 g2 b2 _) = RGBA (r1 * r2) (g1 * g2) (b1 * b2) 1 {-# INLINE abs #-} abs (RGBA r1 g1 b1 _) = RGBA (abs r1) (abs g1) (abs b1) 1 {-# INLINE signum #-} signum (RGBA r1 g1 b1 _) = RGBA (signum r1) (signum g1) (signum b1) 1 {-# INLINE fromInteger #-} fromInteger i = let f = fromInteger i in RGBA f f f 1 -- | Make a custom color. All components are clamped to the range [0..1]. makeColor :: Float -- ^ Red component. -> Float -- ^ Green component. -> Float -- ^ Blue component. -> Float -- ^ Alpha component. -> Color makeColor r g b a = clampColor $ RGBA r g b a {-# INLINE makeColor #-} -- | Make a custom color. -- You promise that all components are clamped to the range [0..1] makeColor' :: Float -> Float -> Float -> Float -> Color makeColor' r g b a = RGBA r g b a {-# INLINE makeColor' #-} -- | Make a custom color. All components are clamped to the range [0..255]. makeColor8 :: Int -- ^ Red component. -> Int -- ^ Green component. -> Int -- ^ Blue component. -> Int -- ^ Alpha component. -> Color makeColor8 r g b a = clampColor $ RGBA (fromIntegral r / 255) (fromIntegral g / 255) (fromIntegral b / 255) (fromIntegral a / 255) {-# INLINE makeColor8 #-} -- | Take the RGBA components of a color. rgbaOfColor :: Color -> (Float, Float, Float, Float) rgbaOfColor (RGBA r g b a) = (r, g, b, a) {-# INLINE rgbaOfColor #-} -- | Make a custom color. -- Components should be in the range [0..1] but this is not checked. rawColor :: Float -- ^ Red component. -> Float -- ^ Green component. -> Float -- ^ Blue component. -> Float -- ^ Alpha component. -> Color rawColor = RGBA {-# INLINE rawColor #-} -- Internal -- | Clamp components of a color into the required range. clampColor :: Color -> Color clampColor cc = let (r, g, b, a) = rgbaOfColor cc in RGBA (min 1 r) (min 1 g) (min 1 b) (min 1 a) -- | Normalise a color to the value of its largest RGB component. normaliseColor :: Color -> Color normaliseColor cc = let (r, g, b, a) = rgbaOfColor cc m = maximum [r, g, b] in RGBA (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 RGBA r1 g1 b1 a1 = c1 RGBA r2 g2 b2 a2 = c2 total = ratio1 + ratio2 m1 = ratio1 / total m2 = ratio2 / total in RGBA (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 RGBA r1 g1 b1 a1 = c1 RGBA r2 g2 b2 a2 = c2 in normaliseColor $ RGBA (r1 + r2) (g1 + g2) (b1 + b2) ((a1 + a2) / 2) -- | Make a dimmer version of a color, scaling towards black. dim :: Color -> Color dim (RGBA r g b a) = RGBA (r / 1.2) (g / 1.2) (b / 1.2) a -- | Make a brighter version of a color, scaling towards white. bright :: Color -> Color bright (RGBA r g b a) = clampColor $ RGBA (r * 1.2) (g * 1.2) (b * 1.2) a -- | Lighten a color, adding white. light :: Color -> Color light (RGBA r g b a) = clampColor $ RGBA (r + 0.2) (g + 0.2) (b + 0.2) a -- | Darken a color, adding black. dark :: Color -> Color dark (RGBA r g b a) = clampColor $ RGBA (r - 0.2) (g - 0.2) (b - 0.2) a -- Pre-defined Colors --------------------------------------------------------- -- | A greyness of a given magnitude. greyN :: Float -- ^ Range is 0 = black, to 1 = white. -> Color greyN n = RGBA n n n 1.0 black, white :: Color black = RGBA 0.0 0.0 0.0 1.0 white = RGBA 1.0 1.0 1.0 1.0 -- Colors from the additive color wheel. red, green, blue :: Color red = RGBA 1.0 0.0 0.0 1.0 green = RGBA 0.0 1.0 0.0 1.0 blue = RGBA 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.7.8.3/Graphics/Gloss/Data/Display.hs0000644000000000000000000000061112150532164016643 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.7.8.3/Graphics/Gloss/Data/Extent.hs0000644000000000000000000001105512150532164016511 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} -- | Represents an integral rectangular area of the 2D plane. -- Using `Int`s (instead of `Float`s) for the bounds means we can safely -- compare extents for equality. module Graphics.Gloss.Data.Extent ( Extent , Coord , makeExtent , takeExtent , squareExtent , sizeOfExtent , isUnitExtent , coordInExtent , pointInExtent , centerCoordOfExtent , cutQuadOfExtent , quadOfCoord , pathToCoord , intersectSegExtent , touchesSegExtent) where import Graphics.Gloss.Data.Point import Graphics.Gloss.Data.Quad import Graphics.Gloss.Geometry.Line import Data.Maybe -- | A rectangular area of the 2D plane. -- We keep the type abstract to ensure that invalid extents cannot be -- constructed. data Extent = Extent Int Int Int Int deriving (Eq, Show) -- | An integral coordinate. type Coord = (Int, Int) -- | Construct an extent. -- The north value must be > south, and east > west, else `error`. makeExtent :: Int -- ^ y max (north) -> Int -- ^ y min (south) -> Int -- ^ x max (east) -> Int -- ^ x min (west) -> Extent makeExtent n s e w | n >= s, e >= w = Extent n s e w | otherwise = error "Graphics.Gloss.Geometry.Extent.makeExtent: invalid extent" -- | Take the NSEW components of an extent. takeExtent :: Extent -> (Int, Int, Int, Int) takeExtent (Extent n s e w) = (n, s, e, w) -- | A square extent of a given size. squareExtent :: Int -> Extent squareExtent i = Extent i 0 i 0 -- | Get the width and height of an extent. sizeOfExtent :: Extent -> (Int, Int) sizeOfExtent (Extent n s e w) = (e - w, n - s) -- | Check if an extent is a square with a width and height of 1. isUnitExtent :: Extent -> Bool isUnitExtent extent = sizeOfExtent extent == (1, 1) -- | Check whether a coordinate lies inside an extent. coordInExtent :: Extent -> Coord -> Bool coordInExtent (Extent n s e w) (x, y) = x >= w && x < e && y >= s && y < n -- | Check whether a point lies inside an extent. pointInExtent :: Extent -> Point -> Bool pointInExtent (Extent n s e w) (x, y) = let n' = fromIntegral n s' = fromIntegral s e' = fromIntegral e w' = fromIntegral w in x >= w' && x <= e' && y >= s' && y <= n' -- | Get the coordinate that lies at the center of an extent. centerCoordOfExtent :: Extent -> (Int, Int) centerCoordOfExtent (Extent n s e w) = ( w + (e - w) `div` 2 , s + (n - s) `div` 2) -- | Cut one quadrant out of an extent. cutQuadOfExtent :: Quad -> Extent -> Extent cutQuadOfExtent quad (Extent n s e w) = let hheight = (n - s) `div` 2 hwidth = (e - w) `div` 2 in case quad of NW -> Extent n (s + hheight) (e - hwidth) w NE -> Extent n (s + hheight) e (w + hwidth) SW -> Extent (n - hheight) s (e - hwidth) w SE -> Extent (n - hheight) s e (w + hwidth) -- | Get the quadrant that this coordinate lies in, if any. quadOfCoord :: Extent -> Coord -> Maybe Quad quadOfCoord extent coord = listToMaybe $ filter (\q -> coordInExtent (cutQuadOfExtent q extent) coord) $ allQuads -- | Constuct a path to a particular coordinate in an extent. pathToCoord :: Extent -> Coord -> Maybe [Quad] pathToCoord extent coord | isUnitExtent extent = Just [] | otherwise = do quad <- quadOfCoord extent coord rest <- pathToCoord (cutQuadOfExtent quad extent) coord return $ quad : rest -- | If a line segment (P1-P2) intersects the outer edge of an extent then -- return the intersection point, that is closest to P1, if any. -- If P1 is inside the extent then `Nothing`. -- -- @ -- P2 -- / -- ----/- -- | / | -- + | -- /------ -- / -- P1 -- @ -- intersectSegExtent :: Point -> Point -> Extent -> Maybe Point intersectSegExtent p1@(x1, y1) p2 (Extent n' s' e' w') -- starts below extent | y1 < s , Just pos <- intersectSegHorzSeg p1 p2 s w e = Just pos -- starts above extent | y1 > n , Just pos <- intersectSegHorzSeg p1 p2 n w e = Just pos -- starts left of extent | x1 < w , Just pos <- intersectSegVertSeg p1 p2 w s n = Just pos -- starts right of extent | x1 > e , Just pos <- intersectSegVertSeg p1 p2 e s n = Just pos -- must be starting inside extent. | otherwise = Nothing where n = fromIntegral n' s = fromIntegral s' e = fromIntegral e' w = fromIntegral w' -- | Check whether a line segment's endpoints are inside an extent, or if it -- intersects with the boundary. touchesSegExtent :: Point -> Point -> Extent -> Bool touchesSegExtent p1 p2 extent = pointInExtent extent p1 || pointInExtent extent p2 || isJust (intersectSegExtent p1 p2 extent) gloss-1.7.8.3/Graphics/Gloss/Data/Picture.hs0000644000000000000000000002451512150532164016662 0ustar0000000000000000 -- | Data types for representing pictures. module Graphics.Gloss.Data.Picture ( Point , Vector , Path , Picture(..) , BitmapData -- * 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 -- * Loading Bitmaps , bitmapOfForeignPtr , bitmapOfByteString , bitmapOfBMP , loadBMP) where import Graphics.Gloss.Data.Color import Graphics.Gloss.Data.Point import Graphics.Gloss.Data.Vector import Graphics.Gloss.Geometry.Angle import Graphics.Gloss.Internals.Render.Bitmap import Codec.BMP import Foreign.ForeignPtr import Foreign.Marshal.Alloc import Foreign.Marshal.Utils import Foreign.Ptr import Data.Word import Data.Monoid import Data.ByteString import System.IO.Unsafe import qualified Data.ByteString.Unsafe as BSU import Prelude hiding (map) -- | A path through the x-y plane. type Path = [Point] -- | A 2D picture data Picture -- Primitives ------------------------------------- -- | A blank picture, with nothing in it. = Blank -- | A convex polygon filled with a solid color. | Polygon Path -- | A line along an arbitrary path. | Line Path -- | A circle with the given radius. | Circle Float -- | A circle with the given thickness and radius. -- If the thickness is 0 then this is equivalent to `Circle`. | ThickCircle Float Float -- | A circular arc drawn counter-clockwise between two angles -- (in degrees) at the given radius. | Arc Float Float Float -- | A circular arc drawn counter-clockwise between two angles -- (in degrees), with the given radius and thickness. -- If the thickness is 0 then this is equivalent to `Arc`. | ThickArc Float Float Float Float -- | Some text to draw with a vector font. | Text String -- | A bitmap image with a width, height and some 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 -- Color ------------------------------------------ -- | A picture drawn with this color. | Color Color Picture -- Transforms ------------------------------------- -- | A picture translated by the given x and y coordinates. | Translate Float Float Picture -- | A picture rotated clockwise by the given angle (in degrees). | Rotate Float Picture -- | A picture scaled by the given x and y factors. | Scale Float Float Picture -- More Pictures ---------------------------------- -- | A picture consisting of several others. | Pictures [Picture] deriving (Show, Eq) -- Instances ------------------------------------------------------------------ instance Monoid Picture where mempty = blank mappend a b = Pictures [a, b] mconcat = Pictures -- 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 -- Bitmaps -------------------------------------------------------------------- -- | O(1). Use a `ForeignPtr` of RGBA data as a bitmap with the given -- width and height. -- 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`. bitmapOfForeignPtr :: Int -> Int -> ForeignPtr Word8 -> Bool -> Picture bitmapOfForeignPtr width height fptr cacheMe = let len = width * height * 4 bdata = BitmapData len fptr in Bitmap width height bdata cacheMe -- | O(size). Copy a `ByteString` of RGBA data into a bitmap with the given -- width and height. -- -- 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`. {-# NOINLINE bitmapOfByteString #-} bitmapOfByteString :: Int -> Int -> ByteString -> Bool -> Picture bitmapOfByteString width height bs cacheMe = unsafePerformIO $ do let len = width * height * 4 ptr <- mallocBytes len fptr <- newForeignPtr finalizerFree ptr BSU.unsafeUseAsCString bs $ \cstr -> copyBytes ptr (castPtr cstr) len let bdata = BitmapData len fptr return $ Bitmap width height bdata cacheMe -- | O(size). Copy a `BMP` file into a bitmap. {-# NOINLINE bitmapOfBMP #-} bitmapOfBMP :: BMP -> Picture bitmapOfBMP bmp = unsafePerformIO $ do let (width, height) = bmpDimensions bmp let bs = unpackBMPToRGBA32 bmp let len = width * height * 4 ptr <- mallocBytes len fptr <- newForeignPtr finalizerFree ptr BSU.unsafeUseAsCString bs $ \cstr -> copyBytes ptr (castPtr cstr) len let bdata = BitmapData len fptr reverseRGBA bdata return $ Bitmap width height bdata True -- | Load an uncompressed 24 or 32bit RGBA BMP file as a bitmap. loadBMP :: FilePath -> IO Picture loadBMP filePath = do ebmp <- readBMP filePath case ebmp of Left err -> error $ show err Right bmp -> return $ bitmapOfBMP bmp -- 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.7.8.3/Graphics/Gloss/Data/Point.hs0000644000000000000000000000270712150532164016337 0ustar0000000000000000{-# OPTIONS -fno-warn-missing-methods -fno-warn-orphans #-} {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} module Graphics.Gloss.Data.Point ( Point , pointInBox) where -- | A point on the x-y plane. -- Points can also be treated as `Vector`s, so "Graphics.Gloss.Data.Vector" -- may also be useful. type Point = (Float, Float) -- | Pretend a point is a number. -- Vectors aren't real numbes according to Haskell, because they don't -- support the multiply and divide field operators. We can pretend they -- are though, and use the (+) and (-) operators as component-wise -- addition and subtraction. -- instance Num Point where (+) (x1, y1) (x2, y2) = (x1 + x2, y1 + y2) (-) (x1, y1) (x2, y2) = (x1 - x2, y1 - y2) (*) (x1, y1) (x2, y2) = (x1 * x2, y1 * y2) signum (x, y) = (signum x, signum y) abs (x, y) = (abs x, abs y) negate (x, y) = (negate x, negate y) fromInteger x = (fromInteger x, fromInteger x) -- | 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.7.8.3/Graphics/Gloss/Data/Quad.hs0000644000000000000000000000051412150532164016132 0ustar0000000000000000 module Graphics.Gloss.Data.Quad ( Quad(..) , allQuads) where -- | Represents a Quadrant in the 2D plane. data Quad = NW -- ^ North West | NE -- ^ North East | SW -- ^ South West | SE -- ^ South East deriving (Show, Eq, Enum) -- | A list of all quadrants. Same as @[NW .. SE]@. allQuads :: [Quad] allQuads = [NW .. SE] gloss-1.7.8.3/Graphics/Gloss/Data/QuadTree.hs0000644000000000000000000001074012150532164016754 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} -- | A QuadTree can be used to recursively divide up 2D space into quadrants. -- The smallest division corresponds to an unit `Extent`, so the total depth -- of the tree will depend on what sized `Extent` you start with. module Graphics.Gloss.Data.QuadTree ( QuadTree (..) , emptyTree , emptyNode , takeQuadOfTree , liftToQuad , insertByPath , insertByCoord , lookupNodeByPath , lookupByPath , lookupByCoord , flattenQuadTree , flattenQuadTreeWithExtents) where import Graphics.Gloss.Data.Quad import Graphics.Gloss.Data.Extent -- | The quad tree structure. data QuadTree a -- | An empty node. = TNil -- | A leaf containint some value. | TLeaf a -- | A node with four children. | TNode (QuadTree a) (QuadTree a) -- NW NE (QuadTree a) (QuadTree a) -- SW SE deriving Show -- | A `TNil` tree. emptyTree :: QuadTree a emptyTree = TNil -- | A node with `TNil`. for all its branches. emptyNode :: QuadTree a emptyNode = TNode TNil TNil TNil TNil -- | Get a quadrant from a node. -- If the tree does not have an outer node then `Nothing`. takeQuadOfTree :: Quad -> QuadTree a -> Maybe (QuadTree a) takeQuadOfTree quad tree = case tree of TNil -> Nothing TLeaf{} -> Nothing TNode nw ne sw se -> case quad of NW -> Just nw NE -> Just ne SW -> Just sw SE -> Just se -- | Apply a function to a quadrant of a node. -- If the tree does not have an outer node then return the original tree. liftToQuad :: Quad -> (QuadTree a -> QuadTree a) -> QuadTree a -> QuadTree a liftToQuad quad f tree = case tree of TNil -> tree TLeaf{} -> tree TNode nw ne sw se -> case quad of NW -> TNode (f nw) ne sw se NE -> TNode nw (f ne) sw se SW -> TNode nw ne (f sw) se SE -> TNode nw ne sw (f se) -- | Insert a value into the tree at the position given by a path. -- If the path intersects an existing `TLeaf` then return the original tree. insertByPath :: [Quad] -> a -> QuadTree a -> QuadTree a insertByPath [] x _ = TLeaf x insertByPath (q:qs) x tree = case tree of TNil -> liftToQuad q (insertByPath qs x) emptyNode TLeaf{} -> tree TNode{} -> liftToQuad q (insertByPath qs x) tree -- | Insert a value into the node containing this coordinate. -- The node is created at maximum depth, corresponding to an unit `Extent`. insertByCoord :: Extent -> Coord -> a -> QuadTree a -> Maybe (QuadTree a) insertByCoord extent coord x tree = do path <- pathToCoord extent coord return $ insertByPath path x tree -- | Lookup a node based on a path to it. lookupNodeByPath :: [Quad] -> QuadTree a -> Maybe (QuadTree a) lookupNodeByPath [] tree = Just tree lookupNodeByPath (q:qs) tree = case tree of TNil -> Nothing TLeaf{} -> Nothing TNode{} -> let Just quad = takeQuadOfTree q tree in lookupNodeByPath qs quad -- | Lookup an element based given a path to it. lookupByPath :: [Quad] -> QuadTree a -> Maybe a lookupByPath path tree = case lookupNodeByPath path tree of Just (TLeaf x) -> Just x _ -> Nothing -- | Lookup a node if a tree given a coordinate which it contains. lookupByCoord :: forall a . Extent -- ^ Extent that covers the whole tree. -> Coord -- ^ Coordinate of the value of interest. -> QuadTree a -> Maybe a lookupByCoord extent coord tree = do path <- pathToCoord extent coord lookupByPath path tree -- | Flatten a QuadTree into a list of its contained values, with coordinates. flattenQuadTree :: forall a . Extent -- ^ Extent that covers the whole tree. -> QuadTree a -> [(Coord, a)] flattenQuadTree extentInit treeInit = flatten' extentInit treeInit where flatten' extent tree = case tree of TNil -> [] TLeaf x -> let (_, s, _, w) = takeExtent extent in [((w, s), x)] TNode{} -> concat $ map (flattenQuad extent tree) allQuads flattenQuad extent tree quad = let extent' = cutQuadOfExtent quad extent Just tree' = takeQuadOfTree quad tree in flatten' extent' tree' -- | Flatten a QuadTree into a list of its contained values, with coordinates. flattenQuadTreeWithExtents :: forall a . Extent -- ^ Extent that covers the whole tree. -> QuadTree a -> [(Extent, a)] flattenQuadTreeWithExtents extentInit treeInit = flatten' extentInit treeInit where flatten' extent tree = case tree of TNil -> [] TLeaf x -> [(extent, x)] TNode{} -> concat $ map (flattenQuad extent tree) allQuads flattenQuad extent tree quad = let extent' = cutQuadOfExtent quad extent Just tree' = takeQuadOfTree quad tree in flatten' extent' tree' gloss-1.7.8.3/Graphics/Gloss/Data/Vector.hs0000644000000000000000000000356612150532164016514 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 , normaliseV , unitVectorAtAngle ) where import Graphics.Gloss.Data.Point import Graphics.Gloss.Geometry.Angle -- | A vector can be treated as a point, and vis-versa. type Vector = Point -- | The magnitude of a vector. magV :: Vector -> Float {-# INLINE magV #-} magV (x, y) = sqrt (x * x + y * y) -- | The angle of this vector, relative to the +ve x-axis. argV :: Vector -> Float {-# INLINE argV #-} argV (x, y) = normaliseAngle $ atan2 y x -- | The dot product of two vectors. dotV :: Vector -> Vector -> Float {-# INLINE dotV #-} dotV (x1, x2) (y1, y2) = x1 * y1 + x2 * y2 -- | The determinant of two vectors. detV :: Vector -> Vector -> Float {-# INLINE detV #-} detV (x1, y1) (x2, y2) = x1 * y2 - y1 * x2 -- | Multiply a vector by a scalar. mulSV :: Float -> Vector -> Vector {-# INLINE mulSV #-} mulSV s (x, y) = (s * x, s * y) -- | Rotate a vector by an angle (in radians). +ve angle is counter-clockwise. rotateV :: Float -> Vector -> Vector {-# INLINE rotateV #-} rotateV r (x, y) = ( x * cos r - y * sin r , x * sin r + y * cos r) -- | Compute the inner angle (in radians) between two vectors. angleVV :: Vector -> Vector -> Float {-# INLINE angleVV #-} angleVV p1 p2 = let m1 = magV p1 m2 = magV p2 d = p1 `dotV` p2 aDiff = acos $ d / (m1 * m2) in aDiff -- | Normalise a vector, so it has a magnitude of 1. normaliseV :: Vector -> Vector {-# INLINE normaliseV #-} normaliseV v = mulSV (1 / magV v) v -- | Produce a unit vector at a given angle relative to the +ve x-axis. -- The provided angle is in radians. unitVectorAtAngle :: Float -> Vector {-# INLINE unitVectorAtAngle #-} unitVectorAtAngle r = (cos r, sin r) gloss-1.7.8.3/Graphics/Gloss/Geometry/0000755000000000000000000000000012150532164015626 5ustar0000000000000000gloss-1.7.8.3/Graphics/Gloss/Geometry/Angle.hs0000644000000000000000000000121612150532164017210 0ustar0000000000000000 -- | Geometric functions concerning angles. If not otherwise specified, all angles are in radians. module Graphics.Gloss.Geometry.Angle ( degToRad , radToDeg , normaliseAngle ) where -- | Convert degrees to radians {-# INLINE degToRad #-} degToRad :: Float -> Float degToRad d = d * pi / 180 -- | Convert radians to degrees {-# INLINE radToDeg #-} radToDeg :: Float -> Float radToDeg r = r * 180 / pi -- | Normalise an angle to be between 0 and 2*pi radians {-# INLINE normaliseAngle #-} normaliseAngle :: Float -> Float normaliseAngle f | f < 0 = normaliseAngle (f + 2 * pi) | f > 2 * pi = normaliseAngle (f - 2 * pi) | otherwise = f gloss-1.7.8.3/Graphics/Gloss/Geometry/Line.hs0000644000000000000000000001656012150532164017061 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.7.8.3/Graphics/Gloss/Interface/0000755000000000000000000000000012150532164015733 5ustar0000000000000000gloss-1.7.8.3/Graphics/Gloss/Interface/IO/0000755000000000000000000000000012150532165016243 5ustar0000000000000000gloss-1.7.8.3/Graphics/Gloss/Interface/IO/Animate.hs0000644000000000000000000000335712150532164020164 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.7.8.3/Graphics/Gloss/Interface/IO/Game.hs0000644000000000000000000000277012150532165017456 0ustar0000000000000000{-# LANGUAGE ExplicitForAll #-} -- | 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.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 = playWithBackendIO defaultBackendState gloss-1.7.8.3/Graphics/Gloss/Interface/IO/Simulate.hs0000644000000000000000000000303712150532164020364 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.Internals.Interface.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.7.8.3/Graphics/Gloss/Interface/Pure/0000755000000000000000000000000012150532164016646 5ustar0000000000000000gloss-1.7.8.3/Graphics/Gloss/Interface/Pure/Animate.hs0000644000000000000000000000212512150532164020560 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.7.8.3/Graphics/Gloss/Interface/Pure/Display.hs0000644000000000000000000000177512150532164020621 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.7.8.3/Graphics/Gloss/Interface/Pure/Game.hs0000644000000000000000000000353512150532164020061 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. play :: 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 -> 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) gloss-1.7.8.3/Graphics/Gloss/Interface/Pure/Simulate.hs0000644000000000000000000000413312150532164020766 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.Internals.Interface.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 :: 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 -> 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.7.8.3/Graphics/Gloss/Internals/0000755000000000000000000000000012150532165015773 5ustar0000000000000000gloss-1.7.8.3/Graphics/Gloss/Internals/Color.hs0000644000000000000000000000075412150532165017413 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.7.8.3/Graphics/Gloss/Internals/Interface/0000755000000000000000000000000012150532165017673 5ustar0000000000000000gloss-1.7.8.3/Graphics/Gloss/Internals/Interface/Animate.hs0000644000000000000000000000546012150532165021612 0ustar0000000000000000 module Graphics.Gloss.Internals.Interface.Animate (animateWithBackendIO) where import Graphics.Gloss.Data.Color import Graphics.Gloss.Data.Picture import Graphics.Gloss.Internals.Render.Picture import Graphics.Gloss.Internals.Render.ViewPort import Graphics.Gloss.Internals.Interface.Backend import Graphics.Gloss.Internals.Interface.Window import Graphics.Gloss.Internals.Interface.Common.Exit import Graphics.Gloss.Internals.Interface.ViewPort import Graphics.Gloss.Internals.Interface.ViewPort.KeyMouse import Graphics.Gloss.Internals.Interface.ViewPort.Motion import Graphics.Gloss.Internals.Interface.ViewPort.Reshape import Graphics.Gloss.Internals.Interface.Animate.Timing import qualified Graphics.Gloss.Internals.Render.State as RS import qualified Graphics.Gloss.Internals.Interface.ViewPort.ControlState as VPC 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 viewPortInit viewControlSR <- newIORef VPC.stateInit animateSR <- newIORef AN.stateInit renderS_ <- RS.stateInit 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 viewS <- readIORef viewSR -- render the frame withViewPort backendRef viewS (renderPicture backendRef renderS viewS 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_viewPort_motion viewSR viewControlSR , callback_viewPort_reshape ] ++ (if pannable then [callback_viewPort_keyMouse viewSR viewControlSR] else []) createWindow backend display backColor callbacks getsIORef :: IORef a -> (a -> r) -> IO r getsIORef ref fun = liftM fun $ readIORef ref gloss-1.7.8.3/Graphics/Gloss/Internals/Interface/Backend.hs0000644000000000000000000000167612150532165021570 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.7.8.3/Graphics/Gloss/Internals/Interface/Callback.hs0000644000000000000000000000051312150532165021722 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.7.8.3/Graphics/Gloss/Internals/Interface/Debug.hs0000644000000000000000000000425612150532165021264 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.7.8.3/Graphics/Gloss/Internals/Interface/Display.hs0000644000000000000000000000346112150532165021640 0ustar0000000000000000 module Graphics.Gloss.Internals.Interface.Display (displayWithBackend) where import Graphics.Gloss.Data.Color import Graphics.Gloss.Data.Picture import Graphics.Gloss.Internals.Render.Picture import Graphics.Gloss.Internals.Render.ViewPort import Graphics.Gloss.Internals.Interface.Backend import Graphics.Gloss.Internals.Interface.Window import Graphics.Gloss.Internals.Interface.Common.Exit import Graphics.Gloss.Internals.Interface.ViewPort import Graphics.Gloss.Internals.Interface.ViewPort.KeyMouse import Graphics.Gloss.Internals.Interface.ViewPort.Motion import Graphics.Gloss.Internals.Interface.ViewPort.Reshape import qualified Graphics.Gloss.Internals.Render.State as RS import qualified Graphics.Gloss.Internals.Interface.ViewPort.ControlState as VPC import qualified Graphics.Gloss.Internals.Interface.Callback as Callback import Data.IORef 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 viewPortInit viewControlSR <- newIORef VPC.stateInit renderS <- RS.stateInit renderSR <- newIORef renderS let renderFun backendRef = do view <- readIORef viewSR options <- readIORef renderSR withViewPort backendRef view (renderPicture backendRef options view picture) let callbacks = [ Callback.Display renderFun -- Escape exits the program , callback_exit () -- Viewport control with mouse , callback_viewPort_keyMouse viewSR viewControlSR , callback_viewPort_motion viewSR viewControlSR , callback_viewPort_reshape ] createWindow backend displayMode background callbacks gloss-1.7.8.3/Graphics/Gloss/Internals/Interface/Game.hs0000644000000000000000000001127612150532165021107 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.Internals.Render.Picture import Graphics.Gloss.Internals.Render.ViewPort import Graphics.Gloss.Internals.Interface.Backend import Graphics.Gloss.Internals.Interface.Window import Graphics.Gloss.Internals.Interface.Common.Exit import Graphics.Gloss.Internals.Interface.ViewPort import Graphics.Gloss.Internals.Interface.ViewPort.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 qualified Graphics.Gloss.Internals.Render.State as RS import Data.IORef import System.Mem -- | Possible input events. data Event = EventKey Key KeyState Modifiers (Float, Float) | EventMotion (Float, Float) deriving (Eq, Show) 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. -> IO () playWithBackendIO backend display backgroundColor simResolution worldStart worldToPicture worldHandleEvent 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 viewPortInit animateSR <- newIORef AN.stateInit renderS_ <- RS.stateInit 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 viewS <- readIORef viewSR -- render the frame withViewPort backendRef viewS (renderPicture backendRef renderS viewS picture) -- perform garbage collection performGC let callbacks = [ Callback.Display (animateBegin animateSR) , Callback.Display displayFun , Callback.Display (animateEnd animateSR) , Callback.Idle (callback_simulate_idle stateSR animateSR viewSR worldSR worldStart (\_ -> worldAdvance) singleStepTime) , callback_exit () , callback_keyMouse worldSR viewSR worldHandleEvent , callback_motion worldSR worldHandleEvent , callback_viewPort_reshape ] createWindow backend display backgroundColor callbacks -- | 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 pos' <- convertPoint backendRef pos world <- readIORef worldRef world' <- eventFn (EventKey key keyState keyMods pos') 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 pos' <- convertPoint backendRef pos world <- readIORef worldRef world' <- eventFn (EventMotion pos') world writeIORef worldRef world' 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.7.8.3/Graphics/Gloss/Internals/Interface/Simulate.hs0000644000000000000000000000632712150532165022022 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.Internals.Render.Picture import Graphics.Gloss.Internals.Render.ViewPort import Graphics.Gloss.Internals.Interface.Backend import Graphics.Gloss.Internals.Interface.Window import Graphics.Gloss.Internals.Interface.Common.Exit import Graphics.Gloss.Internals.Interface.ViewPort import Graphics.Gloss.Internals.Interface.ViewPort.KeyMouse import Graphics.Gloss.Internals.Interface.ViewPort.Motion import Graphics.Gloss.Internals.Interface.ViewPort.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.ViewPort.ControlState as VPC import qualified Graphics.Gloss.Internals.Interface.Simulate.State as SM import qualified Graphics.Gloss.Internals.Interface.Animate.State as AN import qualified Graphics.Gloss.Internals.Render.State as RS 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 viewPortInit viewControlSR <- newIORef VPC.stateInit animateSR <- newIORef AN.stateInit renderS_ <- RS.stateInit 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 viewS <- readIORef viewSR -- render the frame withViewPort backendRef viewS (renderPicture backendRef renderS viewS picture) -- perform garbage collection performGC let callbacks = [ Callback.Display (animateBegin animateSR) , Callback.Display displayFun , Callback.Display (animateEnd animateSR) , Callback.Idle (callback_simulate_idle stateSR animateSR viewSR worldSR worldStart worldAdvance singleStepTime) , callback_exit () , callback_viewPort_keyMouse viewSR viewControlSR , callback_viewPort_motion viewSR viewControlSR , callback_viewPort_reshape ] createWindow backend display backgroundColor callbacks gloss-1.7.8.3/Graphics/Gloss/Internals/Interface/ViewPort.hs0000644000000000000000000000126512150532165022012 0ustar0000000000000000 -- | 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'. module Graphics.Gloss.Internals.Interface.ViewPort ( ViewPort(..) , viewPortInit ) where 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 } gloss-1.7.8.3/Graphics/Gloss/Internals/Interface/Window.hs0000644000000000000000000000354612150532165021506 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.7.8.3/Graphics/Gloss/Internals/Interface/Animate/0000755000000000000000000000000012150532165021251 5ustar0000000000000000gloss-1.7.8.3/Graphics/Gloss/Internals/Interface/Animate/State.hs0000644000000000000000000000272312150532165022671 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.7.8.3/Graphics/Gloss/Internals/Interface/Animate/Timing.hs0000644000000000000000000000561012150532165023036 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.7.8.3/Graphics/Gloss/Internals/Interface/Backend/0000755000000000000000000000000012150532165021222 5ustar0000000000000000gloss-1.7.8.3/Graphics/Gloss/Internals/Interface/Backend/GLFW.hs0000644000000000000000000005060412150532165022322 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 _ = 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.7.8.3/Graphics/Gloss/Internals/Interface/Backend/GLUT.hs0000644000000000000000000003125012150532165022332 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.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.7.8.3/Graphics/Gloss/Internals/Interface/Backend/Types.hs0000644000000000000000000001347412150532165022673 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 | 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.7.8.3/Graphics/Gloss/Internals/Interface/Common/0000755000000000000000000000000012150532165021123 5ustar0000000000000000gloss-1.7.8.3/Graphics/Gloss/Internals/Interface/Common/Exit.hs0000644000000000000000000000102012150532165022361 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.7.8.3/Graphics/Gloss/Internals/Interface/Simulate/0000755000000000000000000000000012150532165021456 5ustar0000000000000000gloss-1.7.8.3/Graphics/Gloss/Internals/Interface/Simulate/Idle.hs0000644000000000000000000001137412150532165022675 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE RankNTypes #-} module Graphics.Gloss.Internals.Interface.Simulate.Idle ( callback_simulate_idle ) where import Graphics.Gloss.Internals.Interface.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 -> IORef ViewPort -- ^ the viewport state -> IORef world -- ^ the current world -> world -- ^ the initial 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 viewSR worldSR worldStart worldAdvance singleStepTime backendRef = {-# SCC "callbackIdle" #-} do simS <- readIORef simSR let result | SM.stateReset simS = simulate_reset simSR worldSR worldStart | SM.stateRun simS = simulate_run simSR animateSR viewSR worldSR worldAdvance | SM.stateStep simS = simulate_step simSR viewSR worldSR worldAdvance singleStepTime | otherwise = \_ -> return () result backendRef -- reset the world to simulate_reset :: IORef SM.State -> IORef a -> a -> IdleCallback simulate_reset simSR worldSR worldStart backendRef = do writeIORef worldSR worldStart simSR `modifyIORef` \c -> c { SM.stateReset = False , SM.stateIteration = 0 , SM.stateSimTime = 0 } Backend.postRedisplay backendRef -- take the number of steps specified by controlWarp simulate_run :: IORef SM.State -> IORef AN.State -> IORef ViewPort -> IORef world -> (ViewPort -> Float -> world -> IO world) -> IdleCallback simulate_run simSR _ viewSR worldSR worldAdvance backendRef = do simS <- readIORef simSR viewS <- readIORef viewSR 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 , SM.stateStepsPerFrame = fromIntegral thisSteps } -- tell glut we want to draw the window after returning Backend.postRedisplay backendRef -- take a single step simulate_step :: IORef SM.State -> IORef ViewPort -> IORef world -> (ViewPort -> Float -> world -> IO world) -> Float -> IdleCallback simulate_step simSR viewSR worldSR worldAdvance singleStepTime backendRef = do viewS <- readIORef viewSR world <- readIORef worldSR world' <- worldAdvance viewS singleStepTime world writeIORef worldSR world' simSR `modifyIORef` \c -> c { SM.stateIteration = SM.stateIteration c + 1 , SM.stateStep = False } 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.7.8.3/Graphics/Gloss/Internals/Interface/Simulate/State.hs0000644000000000000000000000204312150532165023071 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 -- | Whether the animation is free-running (or single step) , stateRun :: !Bool -- | Signals to callbackIdle to take a single step of the automation. , stateStep :: !Bool -- | Signals to callbackIdle to roll-back to the initial world. , stateReset :: !Bool -- | 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 -- | Record how many steps we've been taking per frame , stateStepsPerFrame :: !Int } -- | Initial control state stateInit :: Int -> State stateInit resolution = State { stateIteration = 0 , stateRun = True , stateStep = False , stateReset = False , stateResolution = resolution , stateSimTime = 0 , stateStepsPerFrame = 0 } gloss-1.7.8.3/Graphics/Gloss/Internals/Interface/ViewPort/0000755000000000000000000000000012150532165021452 5ustar0000000000000000gloss-1.7.8.3/Graphics/Gloss/Internals/Interface/ViewPort/Command.hs0000644000000000000000000000357412150532165023375 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} {-# OPTIONS -fno-warn-missing-signatures #-} {-# LANGUAGE PatternGuards #-} module Graphics.Gloss.Internals.Interface.ViewPort.Command ( Command (..) , defaultCommandConfig , isCommand ) where import Graphics.Gloss.Internals.Interface.Backend import qualified Data.Map as Map -- | 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) -- | The default commands 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) ]) ] isCommand commands c key keyMods | Just csMatch <- Map.lookup c commands = or $ map (isCommand2 c key keyMods) csMatch | otherwise = False isCommand2 _ key keyMods cMatch | (keyC, mModsC) <- cMatch , keyC == key , case mModsC of Nothing -> True Just modsC -> modsC == keyMods = True | otherwise = False gloss-1.7.8.3/Graphics/Gloss/Internals/Interface/ViewPort/ControlState.hs0000644000000000000000000000270612150532165024434 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} module Graphics.Gloss.Internals.Interface.ViewPort.ControlState ( State (..) , stateInit ) where import Graphics.Gloss.Internals.Interface.ViewPort.Command import Graphics.Gloss.Internals.Interface.Backend import qualified Data.Map as Map import Data.Map (Map) -- ViewControl State ------------------------------------------------------------------------------ -- | State for controlling the viewport. -- These are used by the viewport control component. data State = State { -- | The command list for the viewport controller. -- These can be safely overwridden at any time by deleting / adding entries to the list. -- Entries at the front of the list take precedence. stateCommands :: !(Map Command [(Key, Maybe Modifiers)]) -- | How much to scale the world by for each step of the mouse wheel. , stateScaleStep :: !Float -- | How many degrees to rotate the world by for each pixel of x motion. , stateRotateFactor :: !Float -- | During viewport translation, -- where the mouse was clicked on the window. , stateTranslateMark :: !(Maybe (Int, Int)) -- | During viewport rotation, -- where the mouse was clicked on the window , stateRotateMark :: !(Maybe (Int, Int)) } -- | The initial view state. stateInit :: State stateInit = State { stateCommands = Map.fromList defaultCommandConfig , stateScaleStep = 0.85 , stateRotateFactor = 0.6 , stateTranslateMark = Nothing , stateRotateMark = Nothing } gloss-1.7.8.3/Graphics/Gloss/Internals/Interface/ViewPort/KeyMouse.hs0000644000000000000000000001325512150532165023555 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE PatternGuards, RankNTypes #-} module Graphics.Gloss.Internals.Interface.ViewPort.KeyMouse (callback_viewPort_keyMouse) where import Graphics.Gloss.Data.Vector import Graphics.Gloss.Geometry.Angle import Graphics.Gloss.Internals.Interface.ViewPort import Graphics.Gloss.Internals.Interface.ViewPort.Command import Graphics.Gloss.Internals.Interface.Backend import qualified Graphics.Gloss.Internals.Interface.ViewPort.ControlState as VPC import Control.Monad import Data.IORef import Data.Maybe -- | Callback to handle keyboard and mouse button events -- for controlling the viewport. callback_viewPort_keyMouse :: IORef ViewPort -- ^ ref to ViewPort state -> IORef VPC.State -- ^ ref to ViewPort Control state -> Callback callback_viewPort_keyMouse portRef controlRef = KeyMouse (viewPort_keyMouse portRef controlRef) viewPort_keyMouse :: IORef ViewPort -> IORef VPC.State -> KeyboardMouseCallback viewPort_keyMouse portRef controlRef stateRef key keyState keyMods pos = do commands <- controlRef `getsIORef` VPC.stateCommands {- putStr $ "keyMouse key = " ++ show key ++ "\n" ++ "keyMouse keyState = " ++ show keyState ++ "\n" ++ "keyMouse keyMods = " ++ show keyMods ++ "\n" -} -- Whether the user is holding down the translate button. currentlyTranslating <- liftM (isJust . VPC.stateTranslateMark) $ readIORef controlRef -- Whether the user is holding down the rotate button. currentlyRotating <- liftM (isJust . VPC.stateRotateMark) $ readIORef controlRef viewPort_keyMouse2 currentlyTranslating currentlyRotating commands where viewPort_keyMouse2 currentlyTranslating currentlyRotating commands -- restore viewport | isCommand commands CRestore key keyMods , keyState == Down = do portRef `modifyIORef` \s -> s { viewPortScale = 1 , viewPortTranslate = (0, 0) , viewPortRotate = 0 } postRedisplay stateRef -- zoom ---------------------------------------- -- zoom out | isCommand commands CBumpZoomOut key keyMods , keyState == Down = do controlZoomOut portRef controlRef postRedisplay stateRef -- zoom in | isCommand commands CBumpZoomIn key keyMods , keyState == Down = do controlZoomIn portRef controlRef postRedisplay stateRef -- bump ------------------------------------- -- bump left | isCommand commands CBumpLeft key keyMods , keyState == Down = do motionBump portRef (20, 0) postRedisplay stateRef -- bump right | isCommand commands CBumpRight key keyMods , keyState == Down = do motionBump portRef (-20, 0) postRedisplay stateRef -- bump up | isCommand commands CBumpUp key keyMods , keyState == Down = do motionBump portRef (0, 20) postRedisplay stateRef -- bump down | isCommand commands CBumpDown key keyMods , keyState == Down = do motionBump portRef (0, -20) postRedisplay stateRef -- bump clockwise | isCommand commands CBumpClockwise key keyMods , keyState == Down = do portRef `modifyIORef` \s -> s { viewPortRotate = (\r -> r + 5) $ viewPortRotate s } postRedisplay stateRef -- bump anti-clockwise | isCommand commands CBumpCClockwise key keyMods , keyState == Down = do portRef `modifyIORef` \s -> s { viewPortRotate = (\r -> r - 5) $ viewPortRotate s } postRedisplay stateRef -- translation -------------------------------------- -- start | isCommand commands CTranslate key keyMods , keyState == Down , not currentlyRotating = do let (posX, posY) = pos controlRef `modifyIORef` \s -> s { VPC.stateTranslateMark = Just ( posX , posY) } postRedisplay stateRef -- end -- 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 = do controlRef `modifyIORef` \s -> s { VPC.stateTranslateMark = Nothing } postRedisplay stateRef -- rotation --------------------------------------- -- start | isCommand commands CRotate key keyMods , keyState == Down , not currentlyTranslating = do let (posX, posY) = pos controlRef `modifyIORef` \s -> s { VPC.stateRotateMark = Just ( posX , posY) } postRedisplay stateRef -- end -- 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 = do controlRef `modifyIORef` \s -> s { VPC.stateRotateMark = Nothing } postRedisplay stateRef -- carry on | otherwise = return () controlZoomIn :: IORef ViewPort -> IORef VPC.State -> IO () controlZoomIn portRef controlRef = do scaleStep <- controlRef `getsIORef` VPC.stateScaleStep portRef `modifyIORef` \s -> s { viewPortScale = viewPortScale s * scaleStep } controlZoomOut :: IORef ViewPort -> IORef VPC.State -> IO () controlZoomOut portRef controlRef = do scaleStep <- controlRef `getsIORef` VPC.stateScaleStep portRef `modifyIORef` \s -> s { viewPortScale = viewPortScale s / scaleStep } motionBump :: IORef ViewPort -> (Float, Float) -> IO () motionBump portRef (bumpX, bumpY) = do (transX, transY) <- portRef `getsIORef` viewPortTranslate scale <- portRef `getsIORef` viewPortScale r <- portRef `getsIORef` viewPortRotate let offset = (bumpX / scale, bumpY / scale) let (oX, oY) = rotateV (degToRad r) offset portRef `modifyIORef` \s -> s { viewPortTranslate = ( transX - oX , transY + oY) } getsIORef :: IORef a -> (a -> r) -> IO r getsIORef ref fun = liftM fun $ readIORef ref gloss-1.7.8.3/Graphics/Gloss/Internals/Interface/ViewPort/Motion.hs0000644000000000000000000000573612150532165023266 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE ScopedTypeVariables, RankNTypes #-} module Graphics.Gloss.Internals.Interface.ViewPort.Motion (callback_viewPort_motion) where import Graphics.Gloss.Data.Vector import Graphics.Gloss.Geometry.Angle import Graphics.Gloss.Internals.Interface.ViewPort import Graphics.Gloss.Internals.Interface.Callback import Graphics.Gloss.Internals.Interface.Backend import qualified Graphics.Gloss.Internals.Interface.ViewPort.ControlState as VPC import qualified Graphics.Rendering.OpenGL.GL as GL import Control.Monad import Data.IORef -- | Callback to handle keyboard and mouse button events -- for controlling the viewport. callback_viewPort_motion :: IORef ViewPort -- ^ ref to ViewPort state -> IORef VPC.State -- ^ ref to ViewPort Control state -> Callback callback_viewPort_motion portRef controlRef = Motion (viewPort_motion portRef controlRef) viewPort_motion :: IORef ViewPort -> IORef VPC.State -> MotionCallback viewPort_motion portRef controlRef stateRef pos = do -- putStr $ "motion pos = " ++ show pos ++ "\n" translateMark <- controlRef `getsIORef` VPC.stateTranslateMark rotateMark <- controlRef `getsIORef` VPC.stateRotateMark (case translateMark of Nothing -> return () Just (markX, markY) -> do motionTranslate portRef controlRef (fromIntegral markX, fromIntegral markY) pos postRedisplay stateRef) (case rotateMark of Nothing -> return () Just (markX, markY) -> do motionRotate portRef controlRef (fromIntegral markX, fromIntegral markY) pos postRedisplay stateRef) motionTranslate :: IORef ViewPort -> IORef VPC.State -> (GL.GLint, GL.GLint) -> (Int, Int) -> IO () motionTranslate portRef controlRef (markX :: GL.GLint, markY :: GL.GLint) (posX, posY) = do (transX, transY) <- portRef `getsIORef` viewPortTranslate scale <- portRef `getsIORef` viewPortScale r <- portRef `getsIORef` viewPortRotate let dX = fromIntegral $ markX - (fromIntegral posX) let dY = fromIntegral $ markY - (fromIntegral posY) let offset = (dX / scale, dY / scale) let (oX, oY) = rotateV (degToRad r) offset portRef `modifyIORef` \s -> s { viewPortTranslate = ( transX - oX , transY + oY) } controlRef `modifyIORef` \s -> s { VPC.stateTranslateMark = Just (fromIntegral posX, fromIntegral posY) } motionRotate :: IORef ViewPort -> IORef VPC.State -> (GL.GLint, GL.GLint) -> (Int, Int) -> IO () motionRotate portRef controlRef (markX :: GL.GLint, _markY :: GL.GLint) (posX, posY) = do rotate <- portRef `getsIORef` viewPortRotate rotateFactor <- controlRef `getsIORef` VPC.stateRotateFactor portRef `modifyIORef` \s -> s { viewPortRotate = rotate + rotateFactor * fromIntegral ((fromIntegral posX) - markX) } controlRef `modifyIORef` \s -> s { VPC.stateRotateMark = Just (fromIntegral posX, fromIntegral posY) } getsIORef :: IORef a -> (a -> r) -> IO r getsIORef ref fun = liftM fun $ readIORef ref gloss-1.7.8.3/Graphics/Gloss/Internals/Interface/ViewPort/Reshape.hs0000644000000000000000000000152512150532165023400 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} module Graphics.Gloss.Internals.Interface.ViewPort.Reshape (callback_viewPort_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_viewPort_reshape :: Callback callback_viewPort_reshape = Reshape (viewPort_reshape) viewPort_reshape :: ReshapeCallback viewPort_reshape stateRef (width,height) = do -- Setup the viewport -- This controls what part of the window openGL renders to. -- We'll use the whole window. -- GL.viewport $= ( GL.Position 0 0 , GL.Size (fromIntegral width) (fromIntegral height)) postRedisplay stateRef gloss-1.7.8.3/Graphics/Gloss/Internals/Render/0000755000000000000000000000000012150532165017212 5ustar0000000000000000gloss-1.7.8.3/Graphics/Gloss/Internals/Render/Bitmap.hs0000644000000000000000000000456712150532165020776 0ustar0000000000000000{-# OPTIONS -fwarn-incomplete-patterns #-} -- | Helper functions for rendering bitmaps module Graphics.Gloss.Internals.Render.Bitmap ( BitmapData(..) , reverseRGBA , bitmapPath , freeBitmapData ) where import Foreign -- | Abstract 32-bit RGBA bitmap data. data BitmapData = BitmapData Int -- length (in bytes) (ForeignPtr Word8) -- pointer to data deriving (Eq) instance Show BitmapData where show _ = "BitmapData" -- | Generates the point path to display the bitmap centred bitmapPath :: Float -> Float -> [(Float, Float)] bitmapPath width height = [(-width', -height'), (width', -height'), (width', height'), (-width', height')] where width' = width / 2 height' = height / 2 -- | Destructively reverse the byte order in an array. -- This is necessary as OpenGL reads pixel data as ABGR, rather than RGBA reverseRGBA :: BitmapData -> IO () reverseRGBA (BitmapData length8 fptr) = withForeignPtr fptr (reverseRGBA_ptr length8) -- | Destructively reverses the byte order in an array. reverseRGBA_ptr :: Int -> Ptr Word8 -> IO () reverseRGBA_ptr length8 ptr8 = go (length8 `div` 4) (castPtr ptr8) 0 where go :: Int -> Ptr Word32 -> Int -> IO () go len ptr count | count < len = do curr <- peekElemOff ptr count let byte0 = shift (isolateByte0 curr) 24 let byte1 = shift (isolateByte1 curr) 8 let byte2 = shift (isolateByte2 curr) (-8) let byte3 = shift (isolateByte3 curr) (-24) pokeElemOff ptr count (byte0 .|. byte1 .|. byte2 .|. byte3) go len ptr (count + 1) | otherwise = return () -- | Frees the allocated memory given to OpenGL to avoid a memory leak freeBitmapData :: Ptr Word8 -> IO () {-# INLINE freeBitmapData #-} freeBitmapData p = free p -- | These functions work as bit masks to isolate the Word8 components {-# INLINE isolateByte0 #-} isolateByte0 :: Word32 -> Word32 isolateByte0 word = word .&. (255 :: Word32) {-# INLINE isolateByte1 #-} isolateByte1 :: Word32 -> Word32 isolateByte1 word = word .&. (65280 :: Word32) {-# INLINE isolateByte2 #-} isolateByte2 :: Word32 -> Word32 isolateByte2 word = word .&. (16711680 :: Word32) {-# INLINE isolateByte3 #-} isolateByte3 :: Word32 -> Word32 isolateByte3 word = word .&. (4278190080 :: Word32) gloss-1.7.8.3/Graphics/Gloss/Internals/Render/Circle.hs0000644000000000000000000002066412150532165020757 0ustar0000000000000000{-# LANGUAGE BangPatterns, MagicHash, PatternGuards #-} {-# OPTIONS_HADDOCK hide #-} -- | Fast(ish) rendering of circles. module Graphics.Gloss.Internals.Render.Circle ( renderCircle , renderArc) where import Graphics.Gloss.Internals.Render.Common import Graphics.Gloss.Geometry.Angle import qualified Graphics.Rendering.OpenGL.GL as GL import GHC.Exts -- | Decide how many line segments to use to render the circle. -- The number of segments we should use to get a nice picture depends on -- the size of the circle on the screen, not its intrinsic radius. -- If the viewport has been zoomed-in then we need to use more segments. -- {-# INLINE circleSteps #-} circleSteps :: Float -> Int circleSteps sDiam | sDiam < 8 = 8 | sDiam < 16 = 16 | sDiam < 32 = 32 | otherwise = 64 -- Circle --------------------------------------------------------------------- -- | Render a circle with the given thickness renderCircle :: Float -> Float -> Float -> Float -> Float -> IO () renderCircle posX posY scaleFactor radius_ thickness_ = go (abs radius_) (abs thickness_) where go radius thickness -- If the circle is smaller than a pixel, render it as a point. | thickness == 0 , radScreen <- scaleFactor * (radius + thickness / 2) , radScreen <= 1 = GL.renderPrimitive GL.Points $ GL.vertex $ GL.Vertex2 (gf posX) (gf posY) -- Render zero thickness circles with lines. | thickness == 0 , radScreen <- scaleFactor * radius , steps <- circleSteps radScreen = renderCircleLine posX posY steps radius -- Some thick circle. | radScreen <- scaleFactor * (radius + thickness / 2) , steps <- circleSteps radScreen = renderCircleStrip posX posY steps radius thickness -- | Render a circle as a line. renderCircleLine :: Float -> Float -> Int -> Float -> IO () renderCircleLine (F# posX) (F# posY) steps (F# rad) = let n = fromIntegral steps !(F# tStep) = (2 * pi) / n !(F# tStop) = (2 * pi) in GL.renderPrimitive GL.LineLoop $ renderCircleLine_step posX posY tStep tStop rad 0.0# {-# INLINE renderCircleLine #-} -- | Render a circle with a given thickness as a triangle strip renderCircleStrip :: Float -> Float -> Int -> Float -> Float -> IO () renderCircleStrip (F# posX) (F# posY) steps r width = let n = fromIntegral steps !(F# tStep) = (2 * pi) / n !(F# tStop) = (2 * pi) + (F# tStep) / 2 !(F# r1) = r - width / 2 !(F# r2) = r + width / 2 in GL.renderPrimitive GL.TriangleStrip $ renderCircleStrip_step posX posY tStep tStop r1 0.0# r2 (tStep `divideFloat#` 2.0#) {-# INLINE renderCircleStrip #-} -- Arc ------------------------------------------------------------------------ -- | Render an arc with the given thickness. renderArc :: Float -> Float -> Float -> Float -> Float -> Float -> Float -> IO () renderArc posX posY scaleFactor radius_ a1 a2 thickness_ = go (abs radius_) (abs thickness_) where go radius thickness -- Render zero thickness arcs with lines. | thickness == 0 , radScreen <- scaleFactor * radius , steps <- circleSteps radScreen = renderArcLine posX posY steps radius a1 a2 -- Some thick arc. | radScreen <- scaleFactor * (radius + thickness / 2) , steps <- circleSteps radScreen = renderArcStrip posX posY steps radius a1 a2 thickness -- | Render an arc as a line. renderArcLine :: Float -> Float -> Int -> Float -> Float -> Float -> IO () renderArcLine (F# posX) (F# posY) steps (F# rad) a1 a2 = let n = fromIntegral steps !(F# tStep) = (2 * pi) / n !(F# tStart) = degToRad a1 !(F# tStop) = degToRad a2 + if a1 >= a2 then 2 * pi else 0 -- force the line to end at the desired angle endVertex = addPointOnCircle posX posY rad tStop in GL.renderPrimitive GL.LineStrip $ do renderCircleLine_step posX posY tStep tStop rad tStart endVertex {-# INLINE renderArcLine #-} -- | Render an arc with a given thickness as a triangle strip renderArcStrip :: Float -> Float -> Int -> Float -> Float -> Float -> Float -> IO () renderArcStrip (F# posX) (F# posY) steps r a1 a2 width = let n = fromIntegral steps tStep = (2 * pi) / n t1 = normaliseAngle $ degToRad a1 t2 = normaliseAngle $ degToRad a2 (tStart, tStop) = if t1 <= t2 then (t1, t2) else (t2, t1) tDiff = tStop - tStart tMid = tStart + tDiff / 2 !(F# tStep') = tStep !(F# tStep2') = tStep / 2 !(F# tStart') = tStart !(F# tStop') = tStop !(F# tCut') = tStop - tStep !(F# tMid') = tMid !(F# r1') = r - width / 2 !(F# r2') = r + width / 2 in GL.renderPrimitive GL.TriangleStrip $ do -- start vector addPointOnCircle posX posY r1' tStart' addPointOnCircle posX posY r2' tStart' -- If we don't have a complete step then just drop a point -- between the two ending lines. if tDiff < tStep then do addPointOnCircle posX posY r1' tMid' -- end vectors addPointOnCircle posX posY r2' tStop' addPointOnCircle posX posY r1' tStop' else do renderCircleStrip_step posX posY tStep' tCut' r1' tStart' r2' (tStart' `plusFloat#` tStep2') -- end vectors addPointOnCircle posX posY r1' tStop' addPointOnCircle posX posY r2' tStop' {-# INLINE renderArcStrip #-} -- Step functions ------------------------------------------------------------- renderCircleLine_step :: Float# -> Float# -> Float# -> Float# -> Float# -> Float# -> IO () renderCircleLine_step posX posY tStep tStop rad tt | tt `geFloat#` tStop = return () | otherwise = do addPointOnCircle posX posY rad tt renderCircleLine_step posX posY tStep tStop rad (tt `plusFloat#` tStep) {-# INLINE renderCircleLine_step #-} renderCircleStrip_step :: Float# -> Float# -> Float# -> Float# -> Float# -> Float# -> Float# -> Float# -> IO () renderCircleStrip_step posX posY tStep tStop r1 t1 r2 t2 | t1 `geFloat#` tStop = return () | otherwise = do addPointOnCircle posX posY r1 t1 addPointOnCircle posX posY r2 t2 renderCircleStrip_step posX posY tStep tStop r1 (t1 `plusFloat#` tStep) r2 (t2 `plusFloat#` tStep) {-# INLINE renderCircleStrip_step #-} addPoint :: Float# -> Float# -> IO () addPoint x y = GL.vertex $ GL.Vertex2 (gf (F# x)) (gf (F# y)) {-# INLINE addPoint #-} addPointOnCircle :: Float# -> Float# -> Float# -> Float# -> IO () addPointOnCircle posX posY rad tt = addPoint (posX `plusFloat#` (rad `timesFloat#` (cosFloat# tt))) (posY `plusFloat#` (rad `timesFloat#` (sinFloat# tt))) {-# INLINE addPointOnCircle #-} {- Unused sector drawing code. Sectors are currently drawn as compound Pictures, but we might want this if we end up implementing the ThickSector version as well. -- | Render a sector as a line. renderSectorLine :: Float -> Float -> Int -> Float -> Float -> Float -> IO () renderSectorLine pX@(F# posX) pY@(F# posY) steps (F# rad) a1 a2 = let n = fromIntegral steps !(F# tStep) = (2 * pi) / n !(F# tStart) = degToRad a1 !(F# tStop) = degToRad a2 + if a1 >= a2 then 2 * pi else 0 -- need to set up the edges of the start/end triangles startVertex = GL.vertex $ GL.Vertex2 (gf pX) (gf pY) endVertex = addPointOnCircle posX posY rad tStop in GL.renderPrimitive GL.LineLoop $ do startVertex renderCircleLine_step posX posY tStep tStop rad tStart endVertex -- | Render a sector. renderSector :: Float -> Float -> Float -> Float -> Float -> Float -> IO () renderSector posX posY scaleFactor radius a1 a2 | radScreen <- scaleFactor * radius , steps <- circleSteps (2 * radScreen) = renderSectorLine posX posY steps radius a1 a2 -} gloss-1.7.8.3/Graphics/Gloss/Internals/Render/Common.hs0000644000000000000000000000110212150532165020770 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} module Graphics.Gloss.Internals.Render.Common where import qualified Graphics.Rendering.OpenGL.GL as GL import Unsafe.Coerce -- | The OpenGL library doesn't seem to provide a nice way convert -- a Float to a GLfloat, even though they're the same thing -- under the covers. -- -- Using realToFrac is too slow, as it doesn't get fused in at -- least GHC 6.12.1 -- gf :: Float -> GL.GLfloat {-# INLINE gf #-} gf x = unsafeCoerce x -- | Used for similar reasons to above gsizei :: Int -> GL.GLsizei {-# INLINE gsizei #-} gsizei x = unsafeCoerce x gloss-1.7.8.3/Graphics/Gloss/Internals/Render/Picture.hs0000644000000000000000000002640412150532165021167 0ustar0000000000000000{-# OPTIONS -fwarn-incomplete-patterns #-} {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE ImplicitParams, ScopedTypeVariables #-} module Graphics.Gloss.Internals.Render.Picture (renderPicture) where import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.Color import Graphics.Gloss.Internals.Interface.Backend import Graphics.Gloss.Internals.Interface.ViewPort import Graphics.Gloss.Internals.Render.State import Graphics.Gloss.Internals.Render.Common import Graphics.Gloss.Internals.Render.Circle import Graphics.Gloss.Internals.Render.Bitmap import System.Mem.StableName import Foreign.ForeignPtr import Data.IORef import Data.List import Control.Monad import Graphics.Rendering.OpenGL (($=), get) import qualified Graphics.Rendering.OpenGL.GL as GL import qualified Graphics.Rendering.OpenGL.GLU.Errors as GLU import qualified Graphics.UI.GLUT as GLUT -- | Render a picture using the given render options and viewport. renderPicture :: forall a . Backend a => IORef a -> State -- ^ The render state -> ViewPort -- ^ The current viewport. -> Picture -- ^ The picture to render. -> IO () renderPicture backendRef renderS viewS picture = do -- This GL state doesn't change during rendering, -- so we can just read it once here (matProj_ :: GL.GLmatrix GL.GLdouble) <- get $ GL.matrix (Just GL.Projection) viewport_ <- get $ GL.viewport windowSize_ <- getWindowDimensions backendRef -- let ?modeWireframe = stateWireframe renderS ?modeColor = stateColor renderS ?refTextures = stateTextures renderS ?matProj = matProj_ ?viewport = viewport_ ?windowSize = windowSize_ -- setup render state for world setLineSmooth (stateLineSmooth renderS) setBlendAlpha (stateBlendAlpha renderS) checkErrors "before drawPicture." drawPicture (viewPortScale viewS) picture checkErrors "after drawPicture." drawPicture :: ( ?modeWireframe :: Bool , ?modeColor :: Bool , ?refTextures :: IORef [Texture]) => Float -> Picture -> IO () drawPicture circScale picture = {-# SCC "drawComponent" #-} case picture of -- nothin' Blank -> return () -- line Line path -> GL.renderPrimitive GL.LineStrip $ vertexPFs path -- polygon (where?) Polygon path | ?modeWireframe -> GL.renderPrimitive GL.LineLoop $ vertexPFs path | otherwise -> GL.renderPrimitive GL.Polygon $ vertexPFs path -- circle Circle radius -> renderCircle 0 0 circScale radius 0 ThickCircle radius thickness -> renderCircle 0 0 circScale radius thickness -- arc Arc a1 a2 radius -> renderArc 0 0 circScale radius a1 a2 0 ThickArc a1 a2 radius thickness -> renderArc 0 0 circScale radius a1 a2 thickness -- stroke text -- text looks weird when we've got blend on, -- so disable it during the renderString call. Text str -> do GL.blend $= GL.Disabled GL.preservingMatrix $ GLUT.renderString GLUT.Roman str GL.blend $= GL.Enabled -- colors with float components. Color col p | ?modeColor -> do oldColor <- get GL.currentColor let (r, g, b, a) = rgbaOfColor col GL.currentColor $= GL.Color4 (gf r) (gf g) (gf b) (gf a) drawPicture circScale p GL.currentColor $= oldColor | otherwise -> drawPicture circScale p -- Translation -------------------------- -- Easy translations are done directly to avoid calling GL.perserveMatrix. Translate posX posY (Circle radius) -> renderCircle posX posY circScale radius 0 Translate posX posY (ThickCircle radius thickness) -> renderCircle posX posY circScale radius thickness Translate posX posY (Arc a1 a2 radius) -> renderArc posX posY circScale radius a1 a2 0 Translate posX posY (ThickArc a1 a2 radius thickness) -> renderArc posX posY circScale radius a1 a2 thickness Translate tx ty (Rotate deg p) -> GL.preservingMatrix $ do GL.translate (GL.Vector3 (gf tx) (gf ty) 0) GL.rotate (gf deg) (GL.Vector3 0 0 (-1)) drawPicture circScale p Translate tx ty p -> GL.preservingMatrix $ do GL.translate (GL.Vector3 (gf tx) (gf ty) 0) drawPicture circScale p -- Rotation ----------------------------- -- Easy rotations are done directly to avoid calling GL.perserveMatrix. Rotate _ (Circle radius) -> renderCircle 0 0 circScale radius 0 Rotate _ (ThickCircle radius thickness) -> renderCircle 0 0 circScale radius thickness Rotate deg (Arc a1 a2 radius) -> renderArc 0 0 circScale radius (a1-deg) (a2-deg) 0 Rotate deg (ThickArc a1 a2 radius thickness) -> renderArc 0 0 circScale radius (a1-deg) (a2-deg) thickness Rotate deg p -> GL.preservingMatrix $ do GL.rotate (gf deg) (GL.Vector3 0 0 (-1)) drawPicture circScale p -- Scale -------------------------------- Scale sx sy p -> GL.preservingMatrix $ do GL.scale (gf sx) (gf sy) 1 let mscale = max sx sy drawPicture (circScale * mscale) p -- Bitmap ------------------------------- Bitmap width height imgData cacheMe -> do -- Load the image data into a texture, -- or grab it from the cache if we've already done that before. tex <- loadTexture ?refTextures width height imgData cacheMe -- Set up wrap and filtering mode GL.textureWrapMode GL.Texture2D GL.S $= (GL.Repeated, GL.Repeat) GL.textureWrapMode GL.Texture2D GL.T $= (GL.Repeated, GL.Repeat) GL.textureFilter GL.Texture2D $= ((GL.Nearest, Nothing), GL.Nearest) -- Enable texturing GL.texture GL.Texture2D $= GL.Enabled GL.textureFunction $= GL.Combine -- Set current texture GL.textureBinding GL.Texture2D $= Just (texObject tex) -- Set to opaque GL.currentColor $= GL.Color4 1.0 1.0 1.0 1.0 -- Draw textured polygon GL.renderPrimitive GL.Polygon $ zipWithM_ (\(pX, pY) (tX, tY) -> do GL.texCoord $ GL.TexCoord2 (gf tX) (gf tY) GL.vertex $ GL.Vertex2 (gf pX) (gf pY)) (bitmapPath (fromIntegral width) (fromIntegral height)) [(0,0), (1.0,0), (1.0,1.0), (0,1.0)] -- Disable texturing GL.texture GL.Texture2D $= GL.Disabled -- Free uncachable texture objects. freeTexture tex Pictures ps -> mapM_ (drawPicture circScale) ps -- Errors --------------------------------------------------------------------- checkErrors :: String -> IO () checkErrors place = do errors <- get $ GLU.errors when (not $ null errors) $ mapM_ (handleError place) errors handleError :: String -> GLU.Error -> IO () handleError place err = case err of GLU.Error GLU.StackOverflow _ -> error $ unlines [ "Gloss / OpenGL Stack Overflow " ++ show place , " This program uses the Gloss vector graphics library, which tried to" , " draw a picture using more nested transforms (Translate/Rotate/Scale)" , " than your OpenGL implementation supports. The OpenGL spec requires" , " all implementations to have a transform stack depth of at least 32," , " and Gloss tries not to push the stack when it doesn't have to, but" , " that still wasn't enough." , "" , " You should complain to your harware vendor that they don't provide" , " a better way to handle this situation at the OpenGL API level." , "" , " To make this program work you'll need to reduce the number of nested" , " transforms used when defining the Picture given to Gloss. Sorry." ] -- Issue #32: Spurious "Invalid Operation" errors under Windows 7 64-bit. -- When using GLUT under Windows 7 it complains about InvalidOperation, -- but doesn't provide any other details. All the examples look ok, so -- we're just ignoring the error for now. GLU.Error GLU.InvalidOperation _ -> return () _ -> error $ unlines [ "Gloss / OpenGL Internal Error " ++ show place , " Please report this on haskell-gloss@googlegroups.com." , show err ] -- Textures ------------------------------------------------------------------- -- | Load a texture. -- If we've seen it before then use the pre-installed one from the texture -- cache, otherwise load it into OpenGL. loadTexture :: IORef [Texture] -> Int -> Int -> BitmapData -> Bool -> IO Texture loadTexture refTextures width height imgData cacheMe = do textures <- readIORef refTextures -- Try and find this same texture in the cache. name <- makeStableName imgData let mTexCached = find (\tex -> texName tex == name && texWidth tex == width && texHeight tex == height) textures case mTexCached of Just tex -> return tex Nothing -> do tex <- installTexture width height imgData cacheMe when cacheMe $ writeIORef refTextures (tex : textures) return tex -- | Install a texture into OpenGL. installTexture :: Int -> Int -> BitmapData -> Bool -> IO Texture installTexture width height bitmapData@(BitmapData _ fptr) cacheMe = do -- Allocate texture handle for texture [tex] <- GL.genObjectNames 1 GL.textureBinding GL.Texture2D $= Just tex -- Sets the texture in imgData as the current texture -- This copies the data from the pointer into OpenGL texture memory, -- so it's ok if the foreignptr gets garbage collected after this. withForeignPtr fptr $ \ptr -> GL.texImage2D Nothing GL.NoProxy 0 GL.RGBA8 (GL.TextureSize2D (gsizei width) (gsizei height)) 0 (GL.PixelData GL.RGBA GL.UnsignedInt8888 ptr) -- Make a stable name that we can use to identify this data again. -- If the user gives us the same texture data at the same size then we -- can avoid loading it into texture memory again. name <- makeStableName bitmapData return Texture { texName = name , texWidth = width , texHeight = height , texData = fptr , texObject = tex , texCacheMe = cacheMe } -- | If this texture does not have its `cacheMe` flag set then delete it from -- OpenGL and free the memory. freeTexture :: Texture -> IO () freeTexture tex | texCacheMe tex = return () | otherwise = GL.deleteObjectNames [texObject tex] -- Utils ---------------------------------------------------------------------- -- | Turn alpha blending on or off setBlendAlpha :: Bool -> IO () setBlendAlpha state | state = do GL.blend $= GL.Enabled GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha) | otherwise = do GL.blend $= GL.Disabled GL.blendFunc $= (GL.One, GL.Zero) -- | Turn line smoothing on or off setLineSmooth :: Bool -> IO () setLineSmooth state | state = GL.lineSmooth $= GL.Enabled | otherwise = GL.lineSmooth $= GL.Disabled vertexPFs :: [(Float, Float)] -> IO () {-# INLINE vertexPFs #-} vertexPFs [] = return () vertexPFs ((x, y) : rest) = do GL.vertex $ GL.Vertex2 (gf x) (gf y) vertexPFs rest gloss-1.7.8.3/Graphics/Gloss/Internals/Render/State.hs0000644000000000000000000000324412150532165020631 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -- | Rendering options module Graphics.Gloss.Internals.Render.State ( State (..) , stateInit , Texture (..)) where import qualified Graphics.Rendering.OpenGL.GL as GL import Foreign.ForeignPtr import System.Mem.StableName import Data.Word import Data.IORef import Graphics.Gloss.Data.Picture -- | Render options settings data State = State { -- | Whether to use color stateColor :: !Bool -- | Whether to force wireframe mode only , stateWireframe :: !Bool -- | Whether to use alpha blending , stateBlendAlpha :: !Bool -- | Whether to use line smoothing , stateLineSmooth :: !Bool -- | Cache of Textures that we've sent to OpenGL. , stateTextures :: !(IORef [Texture]) } -- | A texture that we've sent to OpenGL. data Texture = Texture { -- | Stable name derived from the `BitmapData` that the user gives us. texName :: StableName BitmapData -- | Width of the image, in pixels. , texWidth :: Int -- | Height of the image, in pixels. , texHeight :: Int -- | Pointer to the Raw texture data. , texData :: ForeignPtr Word8 -- | The OpenGL texture object. , texObject :: GL.TextureObject -- | Whether we want to leave this in OpenGL texture memory between frames. , texCacheMe :: Bool } -- | Default render options stateInit :: IO State stateInit = do textures <- newIORef [] return State { stateColor = True , stateWireframe = False , stateBlendAlpha = True , stateLineSmooth = False , stateTextures = textures } gloss-1.7.8.3/Graphics/Gloss/Internals/Render/ViewPort.hs0000644000000000000000000000312212150532165021323 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE ScopedTypeVariables, Rank2Types #-} -- | Handling the current viewport during rendering. module Graphics.Gloss.Internals.Render.ViewPort ( withViewPort ) where import Graphics.Gloss.Internals.Interface.Backend import Graphics.Gloss.Internals.Interface.ViewPort import Graphics.Rendering.OpenGL (GLfloat, ($=)) import qualified Graphics.Rendering.OpenGL.GL as GL import Data.IORef (IORef) -- | Perform a rendering action whilst using the given viewport withViewPort :: forall a . Backend a => IORef a -> ViewPort -- ^ The viewport to use. -> IO () -- ^ The rendering action to perform. -> IO () withViewPort backendRef port action = do GL.matrixMode $= GL.Projection GL.preservingMatrix $ do -- setup the co-ordinate system GL.loadIdentity (sizeX, sizeY) <- getWindowDimensions backendRef let (sx, sy) = (fromIntegral sizeX / 2, fromIntegral sizeY / 2) GL.ortho (-sx) sx (-sy) sy 0 (-100) -- draw the world GL.matrixMode $= GL.Modelview 0 GL.preservingMatrix $ do GL.loadIdentity let rotate :: GLfloat = realToFrac $ viewPortRotate port let transX :: GLfloat = realToFrac $ fst $ viewPortTranslate port let transY :: GLfloat = realToFrac $ snd $ viewPortTranslate port let scale :: GLfloat = realToFrac $ viewPortScale port -- apply the global view transforms GL.scale scale scale 1 GL.rotate rotate (GL.Vector3 0 0 1) GL.translate (GL.Vector3 transX transY 0) -- call the client render action action GL.matrixMode $= GL.Projection GL.matrixMode $= GL.Modelview 0