packages feed

gemstone 0.1 → 0.2

raw patch · 7 files changed

+197/−50 lines, 7 filesdep +randomdep ~linear

Dependencies added: random

Dependency ranges changed: linear

Files

+ Gemstone/Animation.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE TemplateHaskell #-}+module Gemstone.Animation where++import Control.Applicative+import Control.Lens+import Linear++import Gemstone.Box+import Gemstone.Sprite++-- | An animation.+--+--   The type parameter represents units over time; for example, pixels per+--   second.+data Animation a = Animation { _aSprite   :: Sprite a+                             , _aVelocity :: V2 a }+    deriving (Show)++makeLenses ''Animation++-- | Make a simple 'Animation' from a 'Sprite'.+animate :: Num a => Sprite a -> Animation a+animate s = Animation s 0++-- | Move an 'Animation' according to a delta.+moveAnimation :: (Num v, Ord v, Show v) => v -> Animation v -> Animation v+moveAnimation delta animation = animation & aSprite . sBox . bXY %~ f+    where+    v' = animation ^. aVelocity * pure delta+    f (x, y) = case V2 x y + v' of V2 x' y' -> (x', y')
Gemstone/Box.hs view
@@ -2,10 +2,10 @@ module Gemstone.Box (     Box(), BoxLike(..), unBox, box,     pInter, bInter,-    makeXYWH, makeXYWHValid, makeXYXYValid,+    makeXYWH, makeXYWHValid, makeXYXYValid, squareAt,     bLeft, bBot, bRight, bTop,     bW, bH, bW', bH',-    bX, bY, bXY,+    bX, bY, bX', bY', bXY, bXY',     center,     scaleBox, ) where@@ -34,9 +34,9 @@ box :: Ord v => Simple Prism (BoxLike v) (Box v) box = prism unBox f     where-    f b | pred b = Right $ Box b+    f b | predicate b = Right $ Box b         | otherwise = Left b-    pred (BoxLike x1 y1 x2 y2) = pInter x1 y1 x2 y2+    predicate (BoxLike x1 y1 x2 y2) = pInter x1 y1 x2 y2  -- | Whether two boxes intersect. --@@ -66,6 +66,16 @@     Just b -> b     Nothing -> error "makeXYXYValid: Zero width or height" +-- | Put a square around a point.+-- +--   The square is described by the 'x' and 'y' coordinates of the center, and+--   the radius 'r'.+--+--   >>> squareAt 1 1 1+--   Box {unBox = BoxLike {_bx1 = 0, _by1 = 0, _bx2 = 2, _by2 = 2}}+squareAt :: (Num a, Ord a) => a -> a -> a -> Box a+squareAt x y r = makeXYXYValid (x - r) (y - r) (x + r) (y + r)+ -- | Resize a box by moving an edge. -- --   Inherently unsafe.@@ -89,17 +99,24 @@     fmap (\h -> BoxLike x1 (y1 - h) x2 y2) (f (y2 - y1))  -- | Move a box.-bX, bY :: Num a => Simple Lens (Box a) a+bX, bY, 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)+bX' f (Box (BoxLike x1 y1 x2 y2)) =+    fmap (\x' -> Box (BoxLike (x' + x1 - x2) y1 x' y2)) (f x2)+bY' f (Box (BoxLike x1 y1 x2 y2)) =+    fmap (\y' -> Box (BoxLike x1 (y' + y1 - y2) x2 y')) (f y2)  -- Move a box more efficiently.-bXY :: Num a => Simple Lens (Box a) (a, a)+bXY, 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)+bXY' f (Box (BoxLike x1 y1 x2 y2)) = let+    f' (w, h) = Box $ BoxLike (w + x1 - x2) (h + y1 - y2) w h+    in fmap f' $ f (x2, y2)  -- The center of a box. Read-only. center :: Fractional a => Box a -> (a, a)
Gemstone/Color.hs view
@@ -1,9 +1,18 @@ module Gemstone.Color where +import Data.Traversable+import System.Random+ import Graphics.Rendering.OpenGL +import Gemstone.Random+ type RGB = Color3 GLubyte +-- | A color constructor.+makeColor :: GLubyte -> GLubyte -> GLubyte -> RGB+makeColor = Color3+ red, green, blue :: RGB red = Color3 255 0 0 green = Color3 0 255 0@@ -17,3 +26,11 @@ skyBlue = Color3 127 127 255 grassGreen = Color3 0 255 63 stoneGray = Color3 127 127 127++-- | Vary a color by a given amount, using the provide random number+--   generator.+varyColor :: GLubyte -> StdGen -> RGB -> (StdGen, RGB)+varyColor variance gen (Color3 r g b) = (gen', Color3 r' g' b')+    where+    (gen', [r', g', b']) = mapAccumL jitter gen zipped+    zipped = zip [r, g, b] $ repeat variance
+ Gemstone/Particles.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE TemplateHaskell #-}+module Gemstone.Particles where++import Control.Lens+import Data.Traversable+import Data.Word+import System.Random++import Gemstone.Animation+import Gemstone.Box+import Gemstone.Color+import Gemstone.Random+import Gemstone.Sprite++type Particle a = (Animation a, Int)++data Particles a = Particles { _pGen :: StdGen+                             , _pCenter :: (a, a)+                             , _pColor :: RGB+                             , _pColorVariance :: Word8+                             , _pParticles :: [Particle a] }++makeLenses ''Particles++makeParticles :: Num a => Particles a+makeParticles = Particles (mkStdGen 0) (0, 0) black 0 []++-- | Clear out a list of particles without resetting any of the rest of the+--   state.+clearParticles :: Particles a -> Particles a+clearParticles = pParticles .~ []++makeParticle :: (Floating v, Ord v) => (v, v) -> Int -> RGB -> Particle v+makeParticle (x, y) lifetime c = (animate s, lifetime)+    where s = colored c $ squareAt x y 0.005++-- | Update the lifetimes of all of the particles, and cull the dead ones.+filterParticles :: (Ord v, Num v) => Int -> [Particle v] -> [Particle v]+filterParticles ticks =+    filter (^. _2 . to (> 0)) . over (traverse . _2) (\x -> x - ticks)++tickParticles :: (Floating v, Ord v, Random v)+               => Int -> Particles v -> Particles v+tickParticles ticks (Particles g coords@(cx, cy) c cvar ps) =+    Particles g''' coords c cvar ps''+    where+    ps' = filterParticles ticks ps+    ps'' = if length ps < 100 then newParticle : ps' else ps'+    (g', [x, y]) = mapAccumL jitter g [(cx, 0.01), (cy, 0.01)]+    (life, g'') = randomR (50, 1250) g'+    (g''', c') = varyColor cvar g'' c+    newParticle = makeParticle (x, y) life c' & _1 . aSprite . sMaterial %~ f+    f material = case material of+        Colored c'' _ -> Colored c'' . Just . fst $ random g+        x -> x
+ Gemstone/Random.hs view
@@ -0,0 +1,11 @@+module Gemstone.Random where++import Data.Tuple+import System.Random++-- | Add some jitter to a number which can be randomized.+--+--   The result is swapped around so that it can be used with mapAccumL or+--   other poor-man's-State functions.+jitter :: (Num a, Random a) => StdGen -> (a, a) -> (StdGen, a)+jitter g (x, j) = swap $ randomR (x - j, x + j) g
Gemstone/Sprite.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskell #-} module Gemstone.Sprite where  import Control.Lens@@ -6,32 +7,50 @@ import Gemstone.Box import Gemstone.Color -data Sprite v = Colored RGB (Box v)-              | Textured TextureObject (Box v)+data Material = Colored RGB (Maybe GLubyte)+              | Textured TextureObject     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)+data Sprite a = Sprite { _sMaterial :: Material+                       , _sBox :: Box a }+    deriving (Show) -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+makeLenses ''Sprite++addAlpha :: c -> Color3 c -> Color4 c+addAlpha a (Color3 r g b) = Color4 r g b a++drawSprite :: (Ord c, VertexComponent c) => Sprite c -> IO ()+drawSprite (Sprite material b) = case material of+    Colored c malpha -> do+        case malpha of+            Just alpha -> do+                blend $= Enabled+                blendFunc $= (SrcAlpha, OneMinusSrcAlpha)+                color $ addAlpha alpha c+            Nothing -> do+                blend $= Disabled+                color c+        renderPrimitive Quads $ do+            vertex (Vertex2 x y)+            vertex (Vertex2 x' y)+            vertex (Vertex2 x' y')+            vertex (Vertex2 x y')+    Textured texobj -> do+        texture Texture2D $= Enabled+        activeTexture $= TextureUnit 0+        textureBinding Texture2D $= Just texobj+        textureFunction $= Replace+        renderPrimitive Quads $ 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')+        texture Texture2D $= Disabled     where     rbox = remit box     x = b ^. rbox . bLeft@@ -42,21 +61,10 @@     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++-- | Small helper for putting together colored sprites.+colored :: RGB -> Box v -> Sprite v+colored c = Sprite $ Colored c Nothing
gemstone.cabal view
@@ -7,13 +7,18 @@ -- 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+Version:             0.2  -- A short (one-line) description of the package.-Synopsis:            A simple library for SDL+GL games.+Synopsis:            A simple library of helpers for SDL+GL games.  -- A longer description of the package.-Description:         Gemstone helps you build games.+Description:+  Gemstone helps you build games.+  .+  The main goal of Gemstone is to build a library of datatypes, combinators,+  and utilities for building general games. Gemstone differentiates itself+  from other game libraries by being lens-based.  -- URL for the project homepage or repository. Homepage:            http://corbinsimpson.com/@@ -53,12 +58,15 @@   Library-  exposed-modules:   Gemstone.Box+  exposed-modules:   Gemstone.Animation+                   , Gemstone.Box                    , Gemstone.Color                    , Gemstone.GL                    , Gemstone.Loop-                   , Gemstone.Maths                    , Gemstone.Main+                   , Gemstone.Maths+                   , Gemstone.Particles+                   , Gemstone.Random                    , Gemstone.Sprite                    , Gemstone.Timers   @@ -73,7 +81,8 @@                    , bitmap-opengl                    , containers                    , lens-                   , linear+                   , linear == 0.9.*+                   , random                    , stb-image                    , transformers