packages feed

boomslang (empty) → 0.0.1

raw patch · 20 files changed

+1002/−0 lines, 20 filesdep +GLFW-bdep +MonadRandomdep +OpenGLsetup-changed

Dependencies added: GLFW-b, MonadRandom, OpenGL, base, containers, data-accessor, data-accessor-template, font-opengl-basic4x6, mtl, template-haskell

Files

+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple (defaultMain)++main :: IO ()+main = defaultMain
+ boomslang.cabal view
@@ -0,0 +1,69 @@+name:        boomslang+version:     0.0.1++category:    Game++synopsis:    Boomshine clone+description: A clone of Boomshine (see <http://www.k2xl.com/games/boomshine/>).++author:      Brian Lewis <brian@lorf.org>, Ian Taylor <ian@lorf.org>+maintainer:  Brian Lewis <brian@lorf.org>, Ian Taylor <ian@lorf.org>++license:     PublicDomain++-- -- -- -- -- -- -- -- -- --++cabal-version: >= 1.6+build-type:    Simple++-- -- -- -- -- -- -- -- -- --++extra-source-files:+  src/External/Graphics.hs+  src/External/Graphics/Rendering.hs+  src/External/Input/Keyboard.hs+  src/External/Input/Keyboard/Keys.hs+  src/External/Input/Mouse.hs+  src/External/Input/Mouse/Buttons.hs+  src/External/Time.hs+  src/Game/Activity.hs+  src/Game/Entity/Dot.hs+  src/Game/Entity/Dot/Activity.hs+  src/Game/Environment.hs+  src/Game/G.hs+  src/Game/Level.hs+  src/Game/Logic.hs+  src/Game/Score.hs+  src/Game/State.hs+  src/Vector.hs++executable boomslang+  hs-source-dirs:+    src++  main-is: Main.hs++  build-depends:+    GLFW-b                 == 0.*,+    MonadRandom            == 0.*,+    OpenGL                 == 2.4.*,+    base                   == 4.*,+    containers             == 0.*,+    data-accessor          == 0.*,+    data-accessor-template == 0.*,+    font-opengl-basic4x6   == 0.*,+    mtl                    == 1.*,+    template-haskell       == 2.3.*++  ghc-options: -Wall -O2 -funbox-strict-fields+  if impl(ghc >= 6.8)+    ghc-options: -fwarn-tabs++  extensions:+    TemplateHaskell++-- -- -- -- -- -- -- -- -- --++source-repository head+  type:     git+  location: git://github.com/bsl/boomslang.git
+ src/External/Graphics.hs view
@@ -0,0 +1,66 @@+module External.Graphics+  ( withGraphics+  )+  where++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++import Control.Exception (finally)++import Graphics.Rendering.OpenGL (($=))++import qualified Graphics.Rendering.OpenGL as GL+import qualified Graphics.UI.GLFW          as GLFW++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++withGraphics :: IO a -> IO a+withGraphics action =+    (start >> action) `finally` end++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++start :: IO ()+start = do+    GLFW.initialize+    GLFW.openWindow GLFW.defaultDisplayOptions+      { GLFW.displayOptions_width             = 600+      , GLFW.displayOptions_height            = 600+      , GLFW.displayOptions_numRedBits        = 5+      , GLFW.displayOptions_numGreenBits      = 5+      , GLFW.displayOptions_numBlueBits       = 5+      , GLFW.displayOptions_numAlphaBits      = 5+      , GLFW.displayOptions_numFsaaSamples    = Just 8+      , GLFW.displayOptions_windowIsResizable = True+      }+    GLFW.setWindowTitle "boomslang"++    GLFW.setWindowSizeCallback $ \w h -> do+        GL.viewport   $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h))+        GL.matrixMode $= GL.Projection+        GL.loadIdentity+        GL.ortho2D 0 (realToFrac w) (realToFrac h) 0++    GL.clearColor $= GL.Color4 0.025 0.025 0.025 1++    GL.multisample $= GL.Enabled+    GL.blend       $= GL.Enabled+    GL.blendFunc   $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)++    {-+    GL.colorMaterial $= Just (GL.Front, GL.AmbientAndDiffuse)+    GL.depthFunc     $= Nothing++    let light0 = GL.Light 0+    GL.light    light0 $= GL.Enabled+    GL.ambient  light0 $= GL.Color4 0.3 0.3 0.3 1+    GL.diffuse  light0 $= GL.Color4 0.6 0.6 0.6 1+    GL.specular light0 $= GL.Color4 0.1 0.1 0.1 1+    GL.position light0 $= GL.Vertex4 0 0 2 1+    GL.lighting        $= GL.Enabled+    -}++end :: IO ()+end = do+    GLFW.closeWindow+    GLFW.terminate
+ src/External/Graphics/Rendering.hs view
@@ -0,0 +1,102 @@+module External.Graphics.Rendering (renderScene) where++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++import Control.Monad (unless)+import Data.Char     (ord)+import Data.Maybe    (maybe)+import qualified Data.IntMap as M++import Data.Accessor.Basic ((^.))+import qualified Graphics.Rendering.OpenGL as GL+import qualified Graphics.UI.GLFW          as GLFW++import Game.Activity   (Activity(..))+import Game.Entity.Dot (Dot)+import Game.G          (G, ask, get, liftIO)+import Game.Score      (Score(..))+import qualified Game.Entity.Dot  as Dot+import qualified Game.Environment as Environment+import qualified Game.Score       as Score+import qualified Game.State       as State+import qualified Vector           as Vector++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++renderScene :: G ()+renderScene = do+    liftIO $ do+        GL.loadIdentity+        GL.clear [GL.ColorBuffer]++    s <- get+    case s^.State.activity of+      Playing     _ dots        -> mapM_ renderDot dots+      Colliding   _ adots rdots -> mapM_ renderDot adots >>+                                   mapM_ renderDot rdots+      EndingLevel _ dots        -> mapM_ renderDot dots+      _                         -> return ()++    renderStats++    liftIO GLFW.swapBuffers++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++renderDot :: Dot -> G ()+renderDot d = do+    e <- ask+    liftIO $ do+        GL.loadIdentity+        GL.color c+        GL.translate $ GL.Vector3 (Vector.getX p) (Vector.getY p) 0.0+        GL.scale r r 1+        GL.callList (e^.Environment.discDisplayList)+  where+    c = d^.Dot.color+    p = d^.Dot.position+    r = realToFrac $ d^.Dot.radius :: GL.GLdouble++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++renderStats :: G ()+renderStats = do+    s <- get+    let sc = s^.State.score+    unless (sc == NoScore) $+      let numDots          = sc^.Score.numDots+          numDotsRequired  = sc^.Score.numDotsRequired+          numDotsActivated = sc^.Score.numDotsActivated+          numPoints        = sc^.Score.numPoints+          orthoMax         = 100 :: GL.GLdouble+          orthoMin         = negate orthoMax+          scoreText        = show numPoints+      in do+        liftIO $ do+            GL.loadIdentity+            GL.ortho2D orthoMin orthoMax orthoMin orthoMax+            GL.translate (GL.Vector3 (orthoMin + 12) (orthoMin + 6) 0)+            GL.color $ GL.Color4 (1 :: GL.GLfloat) 1 1 1+        renderText $ show numDots ++ ":" ++ show numDotsRequired ++ ":" +++          if numDotsActivated > numDotsRequired+            then show numDotsRequired ++ "+" ++ show (numDotsActivated - numDotsRequired)+            else show numDotsActivated++        -- render Score+        liftIO $ do+            GL.loadIdentity+            GL.ortho2D orthoMin orthoMax orthoMin orthoMax+            let i = 12 + 6 * length scoreText+            GL.translate (GL.Vector3 (orthoMax - fromIntegral i) (orthoMin + 6) 0)+        renderText scoreText++renderText :: String -> G ()+renderText = mapM_ renderChar++renderChar :: Char -> G ()+renderChar c = do+    e <- ask+    liftIO $ maybe+      (return ())+      (\l -> GL.callList l >> GL.translate (GL.Vector3 (6 :: GL.GLdouble) 0 0))+      (M.lookup (ord c) $ e^.Environment.charMap)
+ src/External/Input/Keyboard.hs view
@@ -0,0 +1,18 @@+module External.Input.Keyboard+  ( pressed+  , module External.Input.Keyboard.Keys+  )+  where++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++import qualified Graphics.UI.GLFW as GLFW++import Game.G (G, liftIO)++import External.Input.Keyboard.Keys++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++pressed :: GLFW.Key -> G Bool+pressed = liftIO . GLFW.keyIsPressed
+ src/External/Input/Keyboard/Keys.hs view
@@ -0,0 +1,13 @@+module External.Input.Keyboard.Keys+  ( escape+  , q+  )+  where++import qualified Graphics.UI.GLFW as GLFW++escape :: GLFW.Key+escape = GLFW.KeyEsc++q :: GLFW.Key+q = GLFW.CharKey 'Q'
+ src/External/Input/Mouse.hs view
@@ -0,0 +1,29 @@+module External.Input.Mouse+  ( clicked+  , module External.Input.Mouse.Buttons+  )+  where++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++import qualified Graphics.UI.GLFW as GLFW++import Game.G (G, liftIO)++import External.Input.Mouse.Buttons++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++clicked :: GLFW.MouseButton -> G (Maybe (Double,Double))+clicked b = liftIO $ do+    r <- GLFW.mouseButtonIsPressed b+    if r+      then do+          (x, y) <- GLFW.getMousePosition+          (w, h) <- GLFW.getWindowDimensions+          let w2 = fromIntegral w / 2+              h2 = fromIntegral h / 2+              x' = (fromIntegral x - w2) / w2+              y' = (h2 - fromIntegral y) / h2+          return $ Just (x',y')+      else return Nothing
+ src/External/Input/Mouse/Buttons.hs view
@@ -0,0 +1,16 @@+module External.Input.Mouse.Buttons+  ( left+  , right+  ) where++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++import Graphics.UI.GLFW (MouseButton(..))++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++left :: MouseButton+left = MouseButton0++right :: MouseButton+right = MouseButton1
+ src/External/Time.hs view
@@ -0,0 +1,23 @@+module External.Time+  ( resetTimer+  , readTimer+  , sleep+  )+  where++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++import qualified Graphics.UI.GLFW as GLFW++import Game.G (G, liftIO)++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++resetTimer :: G ()+resetTimer = liftIO GLFW.resetTime++readTimer :: G Double+readTimer = liftIO GLFW.getTime++sleep :: Double -> G ()+sleep = liftIO . GLFW.sleep
+ src/Game/Activity.hs view
@@ -0,0 +1,19 @@+module Game.Activity+  ( Activity (..)+  )+  where++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++import Game.Entity.Dot (Dot)+import Game.Level      (Level)++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++data Activity+  = Starting+  | PreparingLevel !Level+  | Playing        !Level ![Dot]+  | Colliding      !Level ![Dot] ![Dot]+  | EndingLevel    !Level ![Dot]+  | Quitting
+ src/Game/Entity/Dot.hs view
@@ -0,0 +1,47 @@+module Game.Entity.Dot+  ( Dot+  , make+  , radius+  , color+  , position+  , direction+  , velocity+  , activity+  , timestamp+  )+  where++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++import Data.Accessor.Template (deriveAccessors)++import Game.Entity.Dot.Activity (Activity)+import Vector                   (Vec)+import qualified Graphics.Rendering.OpenGL as GL++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++data Dot = Dot+  { radius_    :: !Double+  , color_     :: !(GL.Color4 GL.GLfloat)+  , position_  :: !Vec+  , direction_ :: !Vec+  , velocity_  :: !Double+  , activity_  :: !Activity+  , timestamp_ :: !Double+  } deriving (Show, Eq, Ord)++$(deriveAccessors ''Dot)++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++make+  :: Double+  -> GL.Color4 GL.GLfloat+  -> Vec+  -> Vec+  -> Double+  -> Activity+  -> Double+  -> Dot+make = Dot
+ src/Game/Entity/Dot/Activity.hs view
@@ -0,0 +1,12 @@+module Game.Entity.Dot.Activity+  ( Activity (..)+  )+  where++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++data Activity+  = Roaming+  | Hit+  | None+  deriving (Eq, Show, Ord)
+ src/Game/Environment.hs view
@@ -0,0 +1,98 @@+module Game.Environment+  ( Environment (Environment)+  , normalDotRadius+  , placedDotColor+  , dotVelocity+  , framesPerSecond+  , discDisplayList+  , charMap+  , environment+  )+  where++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++import Control.Monad          (forM)+import Data.Char              (ord)+import qualified Data.IntMap as M++import Data.Accessor.Template (deriveAccessors)++import qualified Graphics.Fonts.OpenGL.Basic4x6 as Basic4x6+import qualified Graphics.Rendering.OpenGL      as GL++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++data Environment = Environment+  { normalDotRadius_ :: !Double+  , placedDotColor_  :: !(GL.Color4 GL.GLfloat)+  , dotVelocity_     :: !Double+  , framesPerSecond_ :: !Double+  , discDisplayList_ :: !GL.DisplayList+  , charMap_         :: !(M.IntMap GL.DisplayList)+  }++$(deriveAccessors ''Environment)++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++disc :: IO ()+disc =+    GL.renderPrimitive GL.TriangleFan $+      mapM_ GL.vertex (centralVertex : outerVertices)+  where+    centralVertex = GL.Vertex2 0 0+    outerVertices = [ GL.Vertex2 (cos r) (sin r) | r <- [0::GL.GLdouble,2*pi/360*12..2*pi] ]++environment :: IO Environment+environment = do+    discDisplayList' <- GL.defineNewList GL.Compile disc+    charMap' <- charToDisplayList+    return Environment+      { normalDotRadius_   = normalDotRadius'+      , placedDotColor_    = translucentWhite+      , dotVelocity_       = 0.2 / framesPerSecond'+      , framesPerSecond_   = framesPerSecond'+      , discDisplayList_   = discDisplayList'+      , charMap_           = charMap'+      }+  where+    normalDotRadius' = 0.04 :: Double+    framesPerSecond' = 60   :: Double++translucentWhite :: GL.Color4 GL.GLfloat+translucentWhite = GL.Color4 1 1 1 0.6++charToDisplayList :: IO (M.IntMap GL.DisplayList)+charToDisplayList =+    M.fromList `fmap` charDisplayLists++charDisplayLists :: IO [(Int,GL.DisplayList)]+charDisplayLists =+    forM chars $ \(c,f) -> do+        dl <- GL.defineNewList GL.Compile f+        return (ord c,dl)++chars :: [(Char,IO ())]+chars =+    [ ('0', Basic4x6.digit0)+    , ('1', Basic4x6.digit1)+    , ('2', Basic4x6.digit2)+    , ('3', Basic4x6.digit3)+    , ('4', Basic4x6.digit4)+    , ('5', Basic4x6.digit5)+    , ('6', Basic4x6.digit6)+    , ('7', Basic4x6.digit7)+    , ('8', Basic4x6.digit8)+    , ('9', Basic4x6.digit9)+    , ('!', Basic4x6.exclamation)+    , ('%', Basic4x6.percent)+    , ('+', Basic4x6.plus)+    , ('-', Basic4x6.minus)+    , ('.', Basic4x6.period)+    , ('/', Basic4x6.slash)+    , (':', Basic4x6.colon)+    , ('<', Basic4x6.lessThan)+    , ('=', Basic4x6.equal)+    , ('>', Basic4x6.greaterThan)+    ]
+ src/Game/G.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Game.G+  ( -- *  Types+    G+    -- *  Utilities+  , runG+    -- *  Reexported+    -- ** Environment+  , ask+  , asks+    -- ** Randomness+  , getRandomR+    -- ** State+  , get+  , put+  , modify+    -- ** IO+  , liftIO+  )+  where++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++import Control.Monad.Random       (MonadRandom, RandT, StdGen, evalRandT, getRandomR, newStdGen)+import Control.Monad.Reader       (MonadReader, ReaderT, runReaderT, ask, asks)+import Control.Monad.State.Strict (MonadState, StateT, evalStateT, get, put, modify)+import Control.Monad.Trans        (MonadIO, liftIO)++import Game.Environment (Environment)+import Game.State       (State)++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++newtype G a = G (ReaderT Environment (RandT StdGen (StateT State IO)) a)+  deriving (Functor, Monad, MonadIO, MonadRandom, MonadReader Environment, MonadState State)++runG :: G a -> Environment -> State -> IO a+runG (G r) e s = do+    sg <- newStdGen+    evalStateT (evalRandT (runReaderT r e) sg) s
+ src/Game/Level.hs view
@@ -0,0 +1,49 @@+module Game.Level+  ( -- * Types+    Level(..)+    -- * Utilities+  , number+  , next+  , numDots+  , numDotsRequired+  )+  where++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++data Level+  = Level1 | Level2 | Level3 | Level4  | Level5  | Level6+  | Level7 | Level8 | Level9 | Level10 | Level11 | Level12+  deriving (Bounded, Enum, Eq, Show)++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++number :: Level -> Integer+number = succ . fromIntegral . fromEnum++next :: Level -> Maybe Level+next c =+    if c == maxLevel+      then Nothing+      else (Just . toEnum . succ . fromEnum) c+  where+    maxLevel = maxBound :: Level++numDots :: Level -> Integer+numDots = (5 *) . succ . fromIntegral . fromEnum++numDotsRequired :: Level -> Integer+numDotsRequired level =+    case level of+      Level1  -> 1+      Level2  -> 2+      Level3  -> 3+      Level4  -> 5+      Level5  -> 7+      Level6  -> 10+      Level7  -> 15+      Level8  -> 21+      Level9  -> 27+      Level10 -> 33+      Level11 -> 44+      Level12 -> 55
+ src/Game/Logic.hs view
@@ -0,0 +1,287 @@+module Game.Logic (logic) where++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++import Control.Monad (replicateM, liftM2, unless, when)+import Data.List     ((\\))++import Data.Accessor.Basic ((^.), (^=), (^:))++import External.Graphics.Rendering (renderScene)+import External.Time               (readTimer, sleep)+import Game.Activity               (Activity(..))+import Game.Entity.Dot             (Dot)+import Game.Entity.Dot.Activity    (Activity(..))+import Game.G                      (G, ask, get, getRandomR, put, modify)+import Game.Level                  (Level(..), numDots, numDotsRequired)+import Game.Score                  (Score(..))+import Vector                      ((^-^), (^+^), (.*^))+import qualified External.Input.Keyboard      as Keyboard+import qualified External.Input.Keyboard.Keys as Keyboard+import qualified External.Input.Mouse         as Mouse+import qualified External.Input.Mouse.Buttons as Mouse+import qualified Game.Activity                as GameActivity+import qualified Game.Entity.Dot              as Dot+import qualified Game.Entity.Dot.Activity     as DotActivity+import qualified Game.Environment             as Environment+import qualified Game.Level                   as Level+import qualified Game.Score                   as Score+import qualified Game.State                   as State+import qualified Graphics.Rendering.OpenGL    as GL+import qualified Vector                       as Vector++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++logic :: G ()+logic =+    loopUntilUserQuits $ do+        t1 <- readTimer+        s <- get+        case s^.State.activity of+          Starting                               -> start+          PreparingLevel level                   -> prepareLevel level+          Playing level dots                     -> play level dots+          Colliding level activeDots roamingDots -> collide level activeDots roamingDots+          EndingLevel level dots                 -> endLevel level dots+          Quitting                               -> return ()+        t2 <- readTimer+        let diff = t2 - t1+        when (diff < limit) (sleep $ limit - diff)+  where+    limit = 1/60++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++unitStep :: Double -> Double+unitStep n =+    if n < 0+      then 0+      else 1++updateDotRadius :: Dot -> G Dot+updateDotRadius dot = do+    t <- readTimer+    let n = t - dot^.Dot.timestamp+    case dot^.Dot.activity of+      Roaming ->+        if n <= 0.1+          then let r = 10 * n * normal+               in return $ Dot.radius ^= r $ dot+          else return dot+      Hit ->+        if n > 3+           then updateActivity None dot+           else let r = if n < 2+                          then normal + adjust * (unitStep (n-exp(-growth))*(log n + growth))/growth+                          else splode * exp (decay * (n-2))+                in return $ Dot.radius ^= r $ dot+      None -> return $ Dot.radius ^= 0 $ dot+  where+    normal = 0.04+    splode = 0.16+    adjust = abs $ splode - normal+    growth = 5+    decay  = negate growth++updateActivity :: DotActivity.Activity -> Dot -> G Dot+updateActivity a d = do+    t <- readTimer+    let dot = Dot.activity  ^= a+            $ Dot.timestamp ^= t $ d+    return dot++activate :: [Dot] -> [Dot] -> G ([Dot],[Dot])+activate activeDots roamingDots = do+    let newActiveDots = filter (\rd -> any (areColliding rd) activeDots) roamingDots+        roamingDots' = roamingDots \\ newActiveDots+    newActiveDots' <- mapM (updateActivity Hit) newActiveDots+    return (activeDots ++ newActiveDots', roamingDots')+  where+    areColliding d0 d1 =+        xDistance < maxDistance &&+        yDistance < maxDistance &&+        vDistance < maxDistance+      where+        xDistance = abs $ x1 - x2+        yDistance = abs $ y1 - y2+        vDistance = Vector.vlen (d0p ^-^ d1p)+        maxDistance = realToFrac $ d0^.Dot.radius + d1^.Dot.radius+        d0p = d0^.Dot.position+        d1p = d1^.Dot.position+        x1 = Vector.getX d0p+        y1 = Vector.getY d0p+        x2 = Vector.getX d1p+        y2 = Vector.getY d1p++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++makeDots :: Integer -> G [Dot]+makeDots n =+    replicateM (fromIntegral n) makeDot++makeDot :: G Dot+makeDot = do+    e <- ask++    -- radius+    let radius = e^.Environment.normalDotRadius++    -- color+    rc <- realToFrac `fmap` randomFloatR 0 1+    gc <- realToFrac `fmap` randomFloatR 0 1+    bc <- realToFrac `fmap` randomFloatR 0 1+    let color = GL.Color4 rc gc bc 0.6++    -- position+    px <- randomDoubleR (radius-1) (1-radius)+    py <- randomDoubleR (radius-1) (1-radius)+    let position = Vector.V (realToFrac px) (realToFrac py)++    -- direction+    dx_ <- randomDoubleR (1/4) (3/4)+    let dy_ = sqrt $ 1-dx_**2+    dx <- fmap (\b -> if b then negate dx_ else dx_) randomBool+    dy <- fmap (\b -> if b then negate dy_ else dy_) randomBool+    let direction = Vector.V (realToFrac dx) (realToFrac dy)++    -- velocity+    let velocity = e^.Environment.dotVelocity++    -- activity+    let activity = Roaming++    t <- readTimer++    return $ Dot.make radius color position direction velocity activity t+  where+    randomFloatR l h  = getRandomR (l,h)              :: G Float+    randomDoubleR l h = getRandomR (l,h)              :: G Double+    randomBool        = fmap (== 0) (getRandomR (0,1) :: G Int)++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++updateDots :: [Dot] -> G [Dot]+updateDots =+    fmap (filter isAlive) . mapM updateDot+  where+    isAlive d = d^.Dot.activity /= None++updateDot :: Dot -> G Dot+updateDot dot =+    case dot^.Dot.activity of+      Roaming -> updateRoamingDot dot+      Hit     -> return dot+      None    -> return dot+    >>= updateDotRadius++updateRoamingDot :: Dot -> G Dot+updateRoamingDot dot = do+    let d   = dot^.Dot.direction+        dx  = Vector.getX d+        dy  = Vector.getY d+        p   = dot^.Dot.position+        r   = dot^.Dot.radius+        v   = dot^.Dot.velocity+        p'  = p ^+^ (realToFrac v .*^ d)+        p'x = realToFrac $ Vector.getX p'+        p'y = realToFrac $ Vector.getY p'+        (p'x',fdx) =+          if p'x+r > 1+            then (2-p'x-(2*r),True)+            else+              if p'x-r < -1+                then (-2-p'x+(2*r),True)+                else (p'x,False)+        (p'y',fdy) =+          if p'y+r > 1+            then (2-p'y-(2*r),True)+            else+              if p'y-r < -1+                then (-2-p'y+(2*r),True)+                else (p'y,False)+        p'' = Vector.V (realToFrac p'x') (realToFrac p'y')+        d'' = Vector.V+               (if fdx then negate dx else dx)+               (if fdy then negate dy else dy)+    return $ Dot.position  ^= p'' $+             Dot.direction ^= d'' $ dot++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++loopUntilUserQuits :: G () ->  G ()+loopUntilUserQuits f = do+    done <- liftM2 (||) (Keyboard.pressed Keyboard.escape) (Keyboard.pressed Keyboard.q)+    unless done (f >> loopUntilUserQuits f)++start :: G ()+start = modify $ (State.activity ^= PreparingLevel Level1) . (State.score ^= NoScore)++prepareLevel :: Level -> G ()+prepareLevel level = do+    s <- get+    dots <- makeDots nd+    put $ State.score    ^= Score nd ndr 0 (np s) $+          State.activity ^= Playing level dots    $ s+  where+    nd   = numDots         level+    ndr  = numDotsRequired level+    np s = if s^.State.score == NoScore then 0 else s^.State.score^.Score.numPoints++play :: Level -> [Dot] -> G ()+play level dots = do+    e <- ask+    dots' <- updateDots dots+    mxy   <- Mouse.clicked Mouse.left+    case mxy of+      Nothing -> modify $ State.activity ^= Playing level dots'+      Just (x,y) -> do+        t <- readTimer+        let radius    = e^.Environment.normalDotRadius+            color     = e^.Environment.placedDotColor+            velocity  = e^.Environment.dotVelocity+            position  = Vector.V (realToFrac x) (realToFrac y)+            direction = Vector.vnull+            activity  = Hit+            dot       = Dot.make radius color position direction velocity activity t+        modify $ State.activity ^= Colliding level [dot] dots'+    renderScene++collide :: Level -> [Dot] -> [Dot] -> G ()+collide level activeDots roamingDots+  | null activeDots = do+      let activity' = EndingLevel level dots'+          dots'     = map (Dot.activity ^= Hit) roamingDots+      modify $ State.activity ^= activity'+  | otherwise = do+      activeDots'  <- updateDots activeDots+      roamingDots' <- updateDots roamingDots+      (activeDots'', roamingDots'') <- activate activeDots' roamingDots'++      s <- get+      let a'  = Colliding level activeDots'' roamingDots''+          p   = fromIntegral $ length activeDots'' - length activeDots'+          sc  = s^.State.score+          sc' = Score.numDotsActivated ^: (p +) $ sc++      put $ State.activity ^= a'  $+            State.score    ^= sc' $ s+      renderScene++endLevel :: Level -> [Dot] -> G ()+endLevel level dots = do+    dots' <- updateDots dots+    s <- get+    if null dots'+      then do+          let sc = s^.State.score+          if (sc^.Score.numDotsActivated) >= (sc^.Score.numDotsRequired)+            then+              case Level.next level of+                Just level' -> put $ State.activity ^= PreparingLevel level'                      $+                                     State.score^:Score.numPoints^:(+ sc^.Score.numDotsActivated) $ s+                Nothing     -> put $ State.activity ^= Starting                                   $+                                     State.score^:Score.numPoints^:(+ sc^.Score.numDotsActivated) $ s+            else put $ State.activity ^= PreparingLevel level $ s+      else do+          put $ State.activity ^= EndingLevel level dots' $ s+          renderScene
+ src/Game/Score.hs view
@@ -0,0 +1,28 @@+module Game.Score+  ( -- * Types+    Score(..)+    -- * Accessors+  , numDots+  , numDotsRequired+  , numDotsActivated+  , numPoints+  )+  where++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++import Data.Accessor.Template (deriveAccessors)++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++data Score+  = NoScore+  | Score+      { numDots_          :: !Integer+      , numDotsRequired_  :: !Integer+      , numDotsActivated_ :: !Integer+      , numPoints_        :: !Integer+      }+  deriving (Eq, Show)++$(deriveAccessors ''Score)
+ src/Game/State.hs view
@@ -0,0 +1,22 @@+module Game.State+  ( State (State)+  , activity+  , score+  )+  where++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++import Data.Accessor.Template (deriveAccessors)++import Game.Activity (Activity)+import Game.Score    (Score)++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++data State = State+  { activity_ :: !Activity+  , score_    :: !Score+  }++$(deriveAccessors ''State)
+ src/Main.hs view
@@ -0,0 +1,15 @@+module Main (main) where++import Game.Activity    (Activity(Starting))+import Game.Environment (environment)+import Game.G           (runG)+import Game.Logic       (logic)+import Game.Score       (Score(NoScore))+import Game.State       (State(State))+import qualified External.Graphics as ExternalGraphics++main :: IO ()+main =+    ExternalGraphics.withGraphics $ do+      env <- environment+      runG logic env (State Starting NoScore)
+ src/Vector.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}++module Vector where++import Graphics.Rendering.OpenGL++data Vec = V+  { getX :: !GLfloat+  , getY :: !GLfloat+  } deriving (Show, Eq, Ord)++infixl 7 ^*.+infixl 7 .*^+infixl 7 ^/.+infixl 7 `dot`+infixl 7 `cross`+infixl 6 ^+^+infixl 6 ^-^++class Vector2D v c | v -> c where+  (^+^) :: v -> v -> v+  (^-^) :: v -> v -> v+  (^*.) :: v -> c -> v+  (.*^) :: c -> v -> v+  (^/.) :: v -> c -> v+  vnull :: v+  dot   :: v -> v -> c+  cross :: v -> v -> c+  vlen  :: v -> c+  mul   :: v -> v -> v++instance Vector2D Vec GLfloat where+  V x1 y1 ^+^ V x2 y2     = V (x1+x2) (y1+y2)+  V x1 y1 ^-^ V x2 y2     = V (x1-x2) (y1-y2)+  V x y ^*. t             = V (x*t) (y*t)+  t .*^ V x y             = V (x*t) (y*t)+  V x y ^/. t             = V (x/t) (y/t)+  vnull                   = V 0 0+  V x1 y1 `dot` V x2 y2   = x1*x2+y1*y2+  V x1 y1 `cross` V x2 y2 = x1*y2-x2*y1+  vlen (V x y)            = sqrt (x*x+y*y)+  V x1 y1 `mul` V x2 y2   = V (x1*x2) (y1*y2)