diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,6 @@
+module Main (main) where
+
+import Distribution.Simple (defaultMain)
+
+main :: IO ()
+main = defaultMain
diff --git a/boomslang.cabal b/boomslang.cabal
new file mode 100644
--- /dev/null
+++ b/boomslang.cabal
@@ -0,0 +1,69 @@
+name: boomslang
+version: 0.0.1
+
+category: Game
+
+synopsis: Boomshine clone
+description: A clone of Boomshine (see ).
+
+author: Brian Lewis , Ian Taylor
+maintainer: Brian Lewis , Ian Taylor
+
+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
diff --git a/src/External/Graphics.hs b/src/External/Graphics.hs
new file mode 100644
--- /dev/null
+++ b/src/External/Graphics.hs
@@ -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
diff --git a/src/External/Graphics/Rendering.hs b/src/External/Graphics/Rendering.hs
new file mode 100644
--- /dev/null
+++ b/src/External/Graphics/Rendering.hs
@@ -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)
diff --git a/src/External/Input/Keyboard.hs b/src/External/Input/Keyboard.hs
new file mode 100644
--- /dev/null
+++ b/src/External/Input/Keyboard.hs
@@ -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
diff --git a/src/External/Input/Keyboard/Keys.hs b/src/External/Input/Keyboard/Keys.hs
new file mode 100644
--- /dev/null
+++ b/src/External/Input/Keyboard/Keys.hs
@@ -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'
diff --git a/src/External/Input/Mouse.hs b/src/External/Input/Mouse.hs
new file mode 100644
--- /dev/null
+++ b/src/External/Input/Mouse.hs
@@ -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
diff --git a/src/External/Input/Mouse/Buttons.hs b/src/External/Input/Mouse/Buttons.hs
new file mode 100644
--- /dev/null
+++ b/src/External/Input/Mouse/Buttons.hs
@@ -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
diff --git a/src/External/Time.hs b/src/External/Time.hs
new file mode 100644
--- /dev/null
+++ b/src/External/Time.hs
@@ -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
diff --git a/src/Game/Activity.hs b/src/Game/Activity.hs
new file mode 100644
--- /dev/null
+++ b/src/Game/Activity.hs
@@ -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
diff --git a/src/Game/Entity/Dot.hs b/src/Game/Entity/Dot.hs
new file mode 100644
--- /dev/null
+++ b/src/Game/Entity/Dot.hs
@@ -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
diff --git a/src/Game/Entity/Dot/Activity.hs b/src/Game/Entity/Dot/Activity.hs
new file mode 100644
--- /dev/null
+++ b/src/Game/Entity/Dot/Activity.hs
@@ -0,0 +1,12 @@
+module Game.Entity.Dot.Activity
+ ( Activity (..)
+ )
+ where
+
+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
+
+data Activity
+ = Roaming
+ | Hit
+ | None
+ deriving (Eq, Show, Ord)
diff --git a/src/Game/Environment.hs b/src/Game/Environment.hs
new file mode 100644
--- /dev/null
+++ b/src/Game/Environment.hs
@@ -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)
+ ]
diff --git a/src/Game/G.hs b/src/Game/G.hs
new file mode 100644
--- /dev/null
+++ b/src/Game/G.hs
@@ -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
diff --git a/src/Game/Level.hs b/src/Game/Level.hs
new file mode 100644
--- /dev/null
+++ b/src/Game/Level.hs
@@ -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
diff --git a/src/Game/Logic.hs b/src/Game/Logic.hs
new file mode 100644
--- /dev/null
+++ b/src/Game/Logic.hs
@@ -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
diff --git a/src/Game/Score.hs b/src/Game/Score.hs
new file mode 100644
--- /dev/null
+++ b/src/Game/Score.hs
@@ -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)
diff --git a/src/Game/State.hs b/src/Game/State.hs
new file mode 100644
--- /dev/null
+++ b/src/Game/State.hs
@@ -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)
diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644
--- /dev/null
+++ b/src/Main.hs
@@ -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)
diff --git a/src/Vector.hs b/src/Vector.hs
new file mode 100644
--- /dev/null
+++ b/src/Vector.hs
@@ -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)