packages feed

gemstone (empty) → 0.1

raw patch · 11 files changed

+431/−0 lines, 11 filesdep +FTGLdep +OpenGLdep +SDLsetup-changed

Dependencies added: FTGL, OpenGL, SDL, SDL-image, array, base, bitmap, bitmap-opengl, containers, lens, linear, stb-image, transformers

Files

+ Gemstone/Box.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE EmptyDataDecls, TemplateHaskell #-}+module Gemstone.Box (+    Box(), BoxLike(..), unBox, box,+    pInter, bInter,+    makeXYWH, makeXYWHValid, makeXYXYValid,+    bLeft, bBot, bRight, bTop,+    bW, bH, bW', bH',+    bX, bY, bXY,+    center,+    scaleBox,+) where++import Control.Lens++data BoxLike v = BoxLike { _bx1, _by1, _bx2, _by2 :: v }+    deriving (Show)++makeLenses ''BoxLike++newtype Box v = Box { unBox :: BoxLike v }+    deriving (Show)++-- | Whether two vertices would determine the lower-left and upper-right corners+--   of a rectangle.+--+--   This is the predicate for determining whether a box is valid.+pInter :: Ord v => v -> v -> v -> v -> Bool+pInter x1 y1 x2 y2 = x1 < x2 && y1 < y2++-- | Prism for getting a Box from a BoxLike.+--+--   The Box constructor isn't exported, so this is the only way to obtain a+--   valid Box.+box :: Ord v => Simple Prism (BoxLike v) (Box v)+box = prism unBox f+    where+    f b | pred b = Right $ Box b+        | otherwise = Left b+    pred (BoxLike x1 y1 x2 y2) = pInter x1 y1 x2 y2++-- | Whether two boxes intersect.+--+--   The boxes have to be good.+bInter :: Ord v => Box v -> Box v -> Bool+bInter (Box b1) (Box b2) =+    pInter (b1 ^. bx1) (b1 ^. by1) (b2 ^. bx2) (b2 ^. by2) &&+    pInter (b2 ^. bx1) (b2 ^. by1) (b1 ^. bx2) (b1 ^. by2)++-- | Make a box with width and height.+makeXYWH :: (Ord v, Num v) => v -> v -> v -> v -> BoxLike v+makeXYWH x y w h = BoxLike x y (x + w) (y + h)++-- | Like makeXYWH, but valid.+--+--   Includes a slap on the face if the box is not valid.+makeXYWHValid :: (Ord v, Num v) => v -> v -> v -> v -> Box v+makeXYWHValid x y w h = case makeXYWH x y w h ^? box of+    Just b -> b+    Nothing -> error "makeXYWHValid: Zero width or height"++-- | Make a valid box.+--+--   Same signature as BoxLike, but making a Box.+makeXYXYValid :: (Ord v, Num v) => v -> v -> v -> v -> Box v+makeXYXYValid x1 y1 x2 y2 = case BoxLike x1 y1 x2 y2 ^? box of+    Just b -> b+    Nothing -> error "makeXYXYValid: Zero width or height"++-- | Resize a box by moving an edge.+--+--   Inherently unsafe.+bLeft, bBot, bRight, bTop :: Simple Lens (BoxLike a) a+bLeft   = bx1+bBot    = by1+bRight  = bx2+bTop    = by2++-- | Resize a box by changing its width or height.+--+--   Inherently unsafe.+bW, bH, bW', bH' :: Num a => Simple Lens (BoxLike a) a+bW  f (BoxLike x1 y1 x2 y2) =+    fmap (\w -> BoxLike x1 y1 (x2 + w) y2) (f (x2 - x1))+bH  f (BoxLike x1 y1 x2 y2) =+    fmap (\h -> BoxLike x1 y1 x2 (y2 + h)) (f (y2 - y1))+bW' f (BoxLike x1 y1 x2 y2) =+    fmap (\w -> BoxLike (x1 - w) y1 x2 y2) (f (x2 - x1))+bH' f (BoxLike x1 y1 x2 y2) =+    fmap (\h -> BoxLike x1 (y1 - h) x2 y2) (f (y2 - y1))++-- | Move a box.+bX, bY :: Num a => Simple Lens (Box a) a+bX f (Box (BoxLike x1 y1 x2 y2)) =+    fmap (\x' -> Box (BoxLike x' y1 (x' + x2 - x1) y2)) (f x1)+bY f (Box (BoxLike x1 y1 x2 y2)) =+    fmap (\y' -> Box (BoxLike x1 y' x2 (y' + y2 - y1))) (f y1)++-- Move a box more efficiently.+bXY :: Num a => Simple Lens (Box a) (a, a)+bXY f (Box (BoxLike x1 y1 x2 y2)) = let+    f' (w, h) = Box $ BoxLike w h (w + x2 - x1) (h + y2 - y1)+    in fmap f' $ f (x1, y1)++-- The center of a box. Read-only.+center :: Fractional a => Box a -> (a, a)+center (Box (BoxLike x1 y1 x2 y2)) = ((x1 + x2) / 2, (y1 + y2) / 2)++-- Scale a box.+scaleBox :: (Eq v, Num v) => v -> v -> Box v -> Box v+scaleBox 0 _ _ = error "scaleBox: Zero width"+scaleBox _ 0 _ = error "scaleBox: Zero height"+scaleBox sx sy (Box (BoxLike x1 y1 x2 y2)) =+    Box $ BoxLike (x1 * sx) (y1 * sy) (x2 * sx) (y2 * sy)
+ Gemstone/Color.hs view
@@ -0,0 +1,19 @@+module Gemstone.Color where++import Graphics.Rendering.OpenGL++type RGB = Color3 GLubyte++red, green, blue :: RGB+red = Color3 255 0 0+green = Color3 0 255 0+blue = Color3 0 0 255++black, white :: RGB+black = Color3 0 0 0+white = Color3 255 255 255++skyBlue, grassGreen, stoneGray :: RGB+skyBlue = Color3 127 127 255+grassGreen = Color3 0 255 63+stoneGray = Color3 127 127 127
+ Gemstone/GL.hs view
@@ -0,0 +1,38 @@+module Gemstone.GL where++import Control.Monad+import Graphics.Rendering.OpenGL+import Graphics.UI.SDL++checkErrors :: IO ()+checkErrors = do+    es <- get errors+    if null es+        then putStrLn "All clear!"+        else putStrLn ("Error: " ++ show es)++checkExtensions :: IO ()+checkExtensions = let+    required = ["ARB_texture_rectangle", "ARB_texture_non_power_of_two"]+    f x = elem $ "GL_" ++ x+    in do+        exts <- get glExtensions+        forM_ required $ \x -> if f x exts+            then putStrLn $ "Found extension " ++ x+            else error $ "Need extension " ++ x++clearScreen :: IO ()+clearScreen = do+    clearColor $= Color4 0.1 0.1 0.1 0.0+    clear [ColorBuffer]++finishFrame :: IO ()+finishFrame = glSwapBuffers++-- | Resize the viewport such that:+--    * The smallest dimension still corresponds to at least [0, 1]+--    * The viewport is centered on (0.5, 0.5)+resizeViewport :: GLsizei -> GLsizei -> IO ()+resizeViewport w h+    | w > h     = viewport $= (Position ((w-3*h) `div` 2) (-h), Size (2*h) (2*h))+    | otherwise = viewport $= (Position (-w) ((h-3*w) `div` 2), Size (2*w) (2*w))
+ Gemstone/Loop.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE TemplateHaskell #-}+module Gemstone.Loop where++import Control.Lens+import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.State+import Graphics.Rendering.OpenGL+import Graphics.UI.SDL++import Gemstone.GL+import Gemstone.Timers++-- | The type of loops.+type Loop a = StateT (Gems, a) IO ()++data Gems = Gems { _gScreen    :: Surface+                 , _gQuitFlag  :: Bool+                 , _gTimers    :: Timers }+    deriving (Show)++makeLenses ''Gems++gems :: Simple Lens (Gems, a) Gems+gems = _1++resizeScreen :: GLsizei -> GLsizei -> IO Surface+resizeScreen w h = let+    flags = [OpenGL, DoubleBuf, Resizable]+    in do+        screen <- setVideoMode (fromIntegral w) (fromIntegral h) 32 flags+        resizeViewport w h+        return screen++getInitialGems :: IO Gems+getInitialGems = do+    screen <- resizeScreen 1 1+    return $ Gems screen False makeTimers++handlePureCoreEvent :: Event -> Gems -> Gems+handlePureCoreEvent (KeyDown (Keysym SDLK_ESCAPE _ _)) = gQuitFlag .~ True+handlePureCoreEvent _ = id++handleCoreEvent :: Event -> StateT Gems IO ()+handleCoreEvent (VideoResize w h) =+    gScreen <~ lift (resizeScreen (fromIntegral w) (fromIntegral h))+handleCoreEvent event = modify $ handlePureCoreEvent event++handleEvents :: (Event -> StateT a IO ()) -> Loop a+handleEvents handler = do+    event <- lift pollEvent+    zoom _1 $ handleCoreEvent event+    zoom _2 $ handler event+    -- Continue until all events have been handled.+    when (event /= NoEvent) $ handleEvents handler
+ Gemstone/Main.hs view
@@ -0,0 +1,14 @@+module Gemstone.Main where++import Control.Monad+import Control.Monad.Trans.State+import Graphics.UI.SDL as SDL++import Gemstone.GL+import Gemstone.Loop++gemstoneMain :: a -> Loop a -> IO ()+gemstoneMain globals loop = withInit [InitEverything] $ do+    initial <- getInitialGems+    checkExtensions+    void $ runStateT loop (initial, globals)
+ Gemstone/Maths.hs view
@@ -0,0 +1,5 @@+module Gemstone.Maths where++-- | Modified Moving Average.+mma :: Fractional a => a -> a -> a+mma new old = (19 * old + new) / 20
+ Gemstone/Sprite.hs view
@@ -0,0 +1,62 @@+module Gemstone.Sprite where++import Control.Lens+import Graphics.Rendering.OpenGL++import Gemstone.Box+import Gemstone.Color++data Sprite v = Colored RGB (Box v)+              | Textured TextureObject (Box v)+    deriving (Show)++sBox :: Simple Lens (Sprite v) (Box v)+sBox f (Colored c b) = fmap (Colored c) (f b)+sBox f (Textured t b) = fmap (Textured t) (f b)++drawSprite :: Sprite GLfloat -> IO ()+drawSprite (Colored c b) = renderPrimitive Quads quad+    where+    rbox = remit box+    x = b ^. rbox . bLeft+    y = b ^. rbox . bBot+    x' = b ^. rbox . bRight+    y' = b ^. rbox . bTop+    quad = do+        color c+        vertex (Vertex2 x y)+        vertex (Vertex2 x' y)+        vertex (Vertex2 x' y')+        vertex (Vertex2 x y')+drawSprite (Textured texobj b) = do+    enableTextures+    renderPrimitive Quads quad+    disableTextures+    where+    rbox = remit box+    x = b ^. rbox . bLeft+    y = b ^. rbox . bBot+    x' = b ^. rbox . bRight+    y' = b ^. rbox . bTop+    r = 0 :: GLfloat+    s = 0 :: GLfloat+    r' = 1+    s' = 1+    enableTextures = do+        texture Texture2D $= Enabled+        activeTexture $= TextureUnit 0+        textureBinding Texture2D $= Just texobj+        textureFunction $= Replace+    disableTextures = texture Texture2D $= Disabled+    quad = do+        texCoord (TexCoord2 r s)+        vertex (Vertex2 x y)+        texCoord (TexCoord2 r' s)+        vertex (Vertex2 x' y)+        texCoord (TexCoord2 r' s')+        vertex (Vertex2 x' y')+        texCoord (TexCoord2 r s')+        vertex (Vertex2 x y')++drawSprites :: [Sprite GLfloat] -> IO ()+drawSprites = mapM_ drawSprite
+ Gemstone/Timers.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE TemplateHaskell #-}+module Gemstone.Timers where++import Control.Lens+import Data.Word++import Gemstone.Maths++data Timers = Timers { _tTimestamp :: Word32+                     , _tDelta     :: Word32+                     , _tFps       :: Float }+    deriving (Show)++makeLenses ''Timers++makeTimers :: Timers+makeTimers = Timers 0 0 0++updateTimestamp :: Word32 -> Timers -> Timers+updateTimestamp w t = let+    delta = w - (t ^. tTimestamp)+    fps = 1000 / fromIntegral delta+    in tTimestamp .~ w $ tDelta .~ delta $ tFps %~ mma fps $ t
+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2013 Corbin Simpson++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ gemstone.cabal view
@@ -0,0 +1,81 @@+-- working.cabal auto-generated by cabal init. For additional options,+-- see+-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.+-- The name of the package.+Name:                gemstone++-- The package version. See the Haskell package versioning policy+-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for+-- standards guiding when and how versions should be incremented.+Version:             0.1++-- A short (one-line) description of the package.+Synopsis:            A simple library for SDL+GL games.++-- A longer description of the package.+Description:         Gemstone helps you build games.++-- URL for the project homepage or repository.+Homepage:            http://corbinsimpson.com/++-- The license under which the package is released.+License:             GPL++-- The file containing the license text.+License-file:        LICENSE++-- The package author(s).+Author:              Corbin Simpson++-- An email address to which users can send suggestions, bug reports,+-- and patches.+Maintainer:          cds@corbinsimpson.com++-- A copyright notice.+-- Copyright:           ++Category:            Game++Build-type:          Simple++-- Extra files to be distributed with the package, such as examples or+-- a README.+-- Extra-source-files:  ++-- Constraint on the version of Cabal needed to build this package.+Cabal-version:       >=1.6+++source-repository head+  type:              git+  location:          git://github.com/MostAwesomeDude/gemstone.git++++Library+  exposed-modules:   Gemstone.Box+                   , Gemstone.Color+                   , Gemstone.GL+                   , Gemstone.Loop+                   , Gemstone.Maths+                   , Gemstone.Main+                   , Gemstone.Sprite+                   , Gemstone.Timers+  +  -- Packages needed in order to build this package.+  Build-depends:     base >= 4 && < 5+                   , FTGL >= 1.333+                   , OpenGL+                   , SDL+                   , SDL-image+                   , array+                   , bitmap+                   , bitmap-opengl+                   , containers+                   , lens+                   , linear+                   , stb-image+                   , transformers++  -- GHC compiler flags. -O2 is not in here at the moment...+  ghc-options:       -Wall -rtsopts