click-clack 1.0 → 1.0.1
raw patch · 10 files changed
+1091/−3 lines, 10 files
Files
- click-clack.cabal +20/−3
- src/Dirty.hs +235/−0
- src/Graphics.hs +70/−0
- src/Inits.hs +138/−0
- src/IxMap.hs +43/−0
- src/Loop.hs +52/−0
- src/Pure.hs +298/−0
- src/Types.hs +155/−0
- src/Utils.hs +22/−0
- src/World.hs +58/−0
click-clack.cabal view
@@ -3,7 +3,7 @@ Tested-With: GHC Category: Little Game Name: click-clack-Version: 1.0+Version: 1.0.1 Stability: provisional License: OtherLicense License-File: LICENSE@@ -16,11 +16,28 @@ go for green balls (plus one live) and orange balls (bonus). Executable click-clack+ Main-is: Main.hs+ hs-source-dirs: src + Other-Modules: + Types+ Loop+ World+ Pure+ Dirty+ Inits+ IxMap+ Graphics+ Utils+ Build-Depends: base >= 3 && < 5, containers >= 0.1 && < 0.5, mtl >= 2, random >= 1, MonadRandom >= 0 && < 1, Hipmunk >= 5.2 && < 5.3, transformers >= 0.2 && < 0.3, OpenGL >= 2.4 && < 2.6, StateVar >= 1.0 && < 1.1, GLFW >= 0.4 && < 0.6- Main-is: Main.hs- hs-source-dirs: src+++ + ++
+ src/Dirty.hs view
@@ -0,0 +1,235 @@+module Dirty where++import System.IO+import Data.Word++import Control.Applicative++import Data.List+import Control.Monad.IO.Class+import Data.IORef+import Data.StateVar++import qualified Physics.Hipmunk as H+import qualified Graphics.UI.GLFW as G+import qualified Graphics.Rendering.OpenGL as G+import Types+import Utils+import Inits++import qualified IxMap as M++import qualified Control.Monad.Random as R+import System.Random++stepDirty :: H.Time -> Dirty -> IO Dirty+stepDirty dt d = H.step (dirtySpace d) dt >> return d+++obj2hero :: Obj -> IO HeroBall+obj2ball :: Id -> Obj -> IO Ball++obj2hero a = do+ p <- get $ objPos a+ v <- get $ objVel a+ return $ HeroBall + { heroPos = p+ , heroVel = H.len v }++obj2ball i a = do+ p <- get $ objPos a+ return $ Ball + { ballId = i+ , ballPos = p+ , ballType = objType a } +++objPos = H.position . objBody+objVel = H.velocity . objBody++getTouch :: Sensor H.Shape -> M.IxMap Obj -> IO (Maybe Event)+getTouch touch objs = do+ val <- getSensor touch + maybe (return Nothing) handleJust val+ where hasShape s obj = s == objShape obj+ handleJust :: H.Shape -> IO (Maybe Event)+ handleJust x = maybe (return Nothing) + (fmap (Just . Touch) . uncurry obj2ball)+ $ find (hasShape x . snd) (M.toList objs) ++getClick :: Sensor H.Position -> IO (Maybe Event)+getClick = fmap (fmap UserClick) . getSensor++getSensor :: Sensor a -> IO (Maybe a)+getSensor ref = do+ val <- get ref+ maybe (return Nothing) handleJust val+ where handleJust a = do+ ref $= Nothing+ return $ Just a+++removeBall :: Ball -> Dirty -> IO Dirty+heroVelocity :: H.Velocity -> Dirty -> IO Dirty+makeBall :: Freq -> Dirty -> IO Dirty+gameOver :: Dirty -> IO Dirty ++----------------------------++gameOver = const $ initDirty++removeBall b d = do+ + H.spaceRemove space $ objBody obj+ H.spaceRemove space $ objShape obj+ return $ d{ dirtyObjs = M.delete k $ dirtyObjs d }+ where k = ballId b+ obj = dirtyObjs d M.! k+ space = dirtySpace d++heroVelocity vel a = ((objVel $ dirtyHero a) $= vel) >> return a++makeBall f a = do + obj <- genBall f (dirtySpace a)+ return $ a{ dirtyObjs = fst $ M.insert obj (dirtyObjs a) }++genBall :: Freq -> H.Space -> IO Obj+genBall f space = do+ bType <- genBallType f+ (p, v) <- genBallState+ ball <- initObj bType p v space+ return ball+ +++genBallType :: Freq -> IO BallType+genBallType f = R.evalRandIO $ R.fromList $ [+ (Good, toRational $ freqGood f), + (Bad, toRational $ freqBad f),+ (Bonus, toRational $ freqBonus f)]+++genBallState :: IO (H.Position, H.Vector)+genBallState = do+ n <- randomRIO (0, 5)+ dx <- randomRIO (-1.0, 1.0)+ dy <- randomRIO (-1.0, 1.0)+ dv <- genBallVelocity ++ let p = holePoints !! n+ return (p, vel (getAngle dx dy p) dv)+ where vel a len = H.scale a len++ getAngle dx dy p = H.normalize $ (vec h2 w2) - p+ where w2 = dx * frameWidth/3+ h2 = dy * frameHeight/3 +++genBallVelocity :: IO H.CpFloat+genBallVelocity = randomRIO (minBallVel, maxBallVel)+ ++------------------------------------------------------------+-- init++initDirty :: IO Dirty+initDirty = do+ space <- initSpace+ hero <- initHero space+ touchVar <- initSensor (touchCallback space)+ mouseVar <- initSensor mouseCallback++ return $ Dirty + { dirtyHero = hero+ , dirtyObjs = M.empty+ , dirtySpace = space+ , dirtyTouchVar = touchVar + , dirtyMouse = mouseVar+ }++initSensor :: (Sensor a -> IO ()) -> IO (Sensor a)+initSensor callback = do+ var <- newIORef Nothing+ callback var+ return var+++initSpace :: IO H.Space+initSpace = do + space <- H.newSpace+ initWalls space+ return space++touchCallback :: H.Space -> Sensor H.Shape -> IO ()+touchCallback space touchVar = do+ H.addCollisionHandler space + (toCollisionType Hero) (toCollisionType Good) handler+ where handler = H.Handler Nothing Nothing (Just handle) Nothing++ handle = do+ (a, b) <- H.shapes+ liftIO $ touchVar $= (Just b)+++mouseCallback :: Sensor H.Position -> IO ()+mouseCallback sensor = do + G.mouseButtonCallback $= (onMouse (updatePos sensor))+ where updatePos sensor = do+ pos <- get G.mousePos+ size <- get G.windowSize+ sensor $= Just (mouse2canvas size pos)++onMouse act key keyState = case (key, keyState) of+ (G.ButtonLeft, G.Press) -> act+ _ -> return ()+++mouse2canvas :: G.Size -> G.Position -> H.Vector+mouse2canvas (G.Size sx sy) (G.Position mx my) = H.Vector x y+ where d a b = fromIntegral a / fromIntegral b+ x = windowWidth * (d mx sx - 0.5)+ y = windowHeight * (negate $ d my sy - 0.5)+++initHero :: H.Space -> IO Obj+initHero = initObj Hero (vec 0 0) (vec 0 0)++initObj :: BallType -> H.Position -> H.Vector -> H.Space -> IO Obj+initObj ballType pos vel space = do+ b <- H.newBody mass $ H.momentForCircle mass (0, radius) 0+ s <- H.newShape b (H.Circle radius) 0+ H.position b $= pos+ H.velocity b $= vel+ + H.elasticity s $= 0.9999+ H.collisionType s $= toCollisionType ballType++ H.spaceAdd space b + H.spaceAdd space s++ return $ (Obj ballType s b)+ where mass = 20+ radius = ballRadius+++toCollisionType :: BallType -> Word32+toCollisionType a = case a of+ Hero -> 1+ _ -> 2+++initWalls :: H.Space -> IO ()+initWalls space = mapM_ f wallPoints+ where f (a, b) = initWall a b space+++initWall :: H.Position -> H.Position -> H.Space -> IO ()+initWall pa pb space = do + b <- H.newBody H.infinity H.infinity+ s <- H.newShape b (H.LineSegment pa pb wallThickness) 0+ H.elasticity s $= 0.9999+ H.spaceAdd space b+ H.spaceAdd space s+ return ()+ +
+ src/Graphics.hs view
@@ -0,0 +1,70 @@+module Graphics where++import Prelude hiding (lines)++import qualified Graphics.Rendering.OpenGL as G+import qualified Graphics.UI.GLFW as G++import Types+import Utils+ +black = Color 0 0 0+red = Color 1 0 0+green = Color 0 1 0+blue = Color 0 0 1+orange = Color 1 0.5 0+yellow = Color 1 1 0 +skyBlue = Color 0 1 1+violet = Color 1 0 1++raduga = [red, orange, yellow, green, skyBlue, blue, violet]++draw :: Picture -> IO ()+draw a = do+ G.clear [G.ColorBuffer]+ foldPicture (return ()) drawPrim (>>) a+ G.swapBuffers+ where drawPrim (Color r g b) prim = do+ G.color $ G.Color4 (d2gl r) (d2gl g) (d2gl b) 1+ drawPrimitive prim +++drawPrimitive :: Primitive -> IO ()+drawPrimitive a = case a of+ Line pa pb -> lines [glPoint pa, glPoint pb]+ Circle pc rad -> lineLoop $ circlePoints (glPoint pc) (d2gl rad) + Rect pa pb -> lineLoop $ rectPoints (glPoint pa) (glPoint pb) + CircleSolid pc rad -> polygon $ circlePoints (glPoint pc) (d2gl rad)+ RectSolid pa pb -> polygon $ rectPoints (glPoint pa) (glPoint pb)+ Text pa msg -> drawText (glPoint pa) msg+ where glPoint (Point x y) = (d2gl x, d2gl y)+++type GLpoint = (G.GLfloat, G.GLfloat)++circlePoints (cx, cy) rad = zip xs ys+ where n = 50+ xs = fmap (\x -> cx + rad * sin (2*pi*x/n)) [0 .. n]+ ys = fmap (\x -> cy + rad * cos (2*pi*x/n)) [0 .. n]++rectPoints (ax, ay) (bx, by) = + [(ax, ay), (ax, by), (bx, by), (bx, ay), (ax, ay)]+++lines = primitive G.Lines+lineLoop = primitive G.LineLoop+polygon = primitive G.Polygon ++primitive primType = + G.renderPrimitive primType . mapM_ (uncurry vertex2f) ++++drawText :: GLpoint -> String -> IO ()+drawText (a, b) msg = G.preservingMatrix $ + G.translate (G.Vector3 a b 0) >>+ G.scale (1.5::G.GLfloat) 1.5 1 >> G.renderString G.Fixed8x16 msg+ ++ +
+ src/Inits.hs view
@@ -0,0 +1,138 @@+module Inits where++import Types+import qualified Physics.Hipmunk as H+import Utils++title = "click-clack"+++----------------------------+-- inits++-- frames per second+fps :: Int+fps = 60++-- frame time in milliseconds+frameTime :: Time+frameTime = 1000 * ((1::Double) / fromIntegral fps)++dt :: H.Time+dt = 0.2++minVel :: H.CpFloat+minVel = 9++creationPeriod :: Int+creationPeriod = 170++windowWidth, windowHeight, frameWidth, frameHeight, + frameOffset, wallOffset, w2, h2, o2 :: Double++frameOffset = 50+frameWidth = 700 +frameHeight = 500+wallOffset = 40++windowWidth = frameWidth + 2*frameOffset+windowHeight = frameHeight + 2*frameOffset++w2 = frameWidth/2; h2 = frameHeight/2; o2 = wallOffset/2++ballRadius :: Double+ballRadius = 11++bonusRadius :: Double+bonusRadius = frameHeight / 2.7++bonusSleep :: Int+bonusSleep = 7+++holePoints :: [H.Position]+holePoints = [+ vec (-w2+dt) (-h2+dt),+ vec 0 (-h2+dt),+ vec (w2-dt) (-h2+dt),+ vec (-w2+dt) (h2-dt),+ vec 0 (h2-dt),+ vec (w2-dt) (h2-dt)+ ]+ where dt = 5++wallPoints :: [(H.Position, H.Position)]+wallPoints = [+ (vec (-w2+o2) (-h2), vec (-o2) (-h2)),+ (vec o2 (-h2), vec (w2-o2) (-h2)),+ + (vec (-w2+o2) h2, vec (-o2) h2),+ (vec o2 h2, vec (w2-o2) h2),+ + (vec (-w2) (h2-o2), vec (-w2) (-h2+o2)),+ (vec w2 (h2-o2), vec w2 (-h2+o2))]+++goodBallCount, bonusBallCount, badBallCount :: Int++goodBallCount = 2+bonusBallCount = 4+badBallCount = 13++livesNum :: Int+livesNum = 15++bonusNum :: Int+bonusNum = 40++minBallVel, maxBallVel :: H.CpFloat++minBallVel = 7+maxBallVel = 11+++wallThickness :: Double+wallThickness = 1+++scoresY1, scoresWidth, scoresX1, scoresX2, scoresHeight :: Double++scoresY1 = h2+30+scoresY2 = scoresY1 - scoresHeight++scoresX1 = -w2+o2+scoresX2 = w2 - scoresWidth-o2++scoresHeight = 20+scoresWidth = 100+++livesRect :: Double -> (Point, Point)+livesRect k = + ((Point scoresX1 scoresY1), + (Point (scoresX1+k*scoresWidth) scoresY2))++bonusRect :: Double -> (Point, Point)+bonusRect k = + ((Point scoresX2 scoresY1), + (Point (scoresX2+k*scoresWidth) scoresY2))++++resultPoint = Point (scoresX2-25) (scoresY2 )+++-- level up' we make it harder+-- by rising number of balls++incrBad, incrBonus, incrGood :: Int -> Int -> Int++incrBad = const (+3)+incrBonus level+ | even level = (+1)+ | otherwise = (+2)+incrGood level + | even level = succ + | otherwise = id ++
+ src/IxMap.hs view
@@ -0,0 +1,43 @@+module IxMap(+ IxMap, empty, + insert, delete, (!),+ fromList, toList) +where++import qualified Data.Map as M++data IxMap a = IxMap + { ixMapData :: M.Map Int a+ , ixMapFreshIds :: [Int]+ }+++instance Functor IxMap where+ fmap f a = a{ ixMapData = M.map f $ ixMapData a}+ ++empty :: IxMap a+empty = IxMap M.empty [0 ..]+++insert :: a -> IxMap a -> (IxMap a, Int)+insert a m = (IxMap (M.insert k a (ixMapData m)) ks, k)+ where k:ks = ixMapFreshIds m++delete :: Int -> IxMap a -> IxMap a+delete k m = IxMap (M.delete k $ ixMapData m) (k : ixMapFreshIds m)+++fromList :: [a] -> IxMap a+fromList as = IxMap (M.fromList (zip [0..] as)) [n..]+ where n = length as+ ++(!) :: IxMap a -> Int -> a+(!) m k = ixMapData m M.! k+++toList :: IxMap a -> [(Int, a)]+toList = M.toList . ixMapData++
+ src/Loop.hs view
@@ -0,0 +1,52 @@+module Loop where++import Data.IORef+import Data.StateVar+import qualified Graphics.UI.GLFW as G+import qualified Graphics.Rendering.OpenGL as G+import qualified Physics.Hipmunk as H++import System.Exit++import World +import Types+import Inits+import Utils++gameLoop :: IO ()+gameLoop = do+ initGame+ loop =<< newIORef =<< initWorld+++loop :: IORef World -> IO ()+loop worldRef = do+ world <- get worldRef+ drawWorld world+ (world, dt) <- updateWorld world+ worldRef $= world+ G.sleep (max 0 $ frameTime - dt) + loop worldRef+ ++initGame :: IO ()+initGame = do + H.initChipmunk+ initGLFW++-- initGLFW++initGLFW :: IO ()+initGLFW = do+ G.initialize+ G.openWindow (G.Size (d2gli windowWidth) (d2gli windowHeight)) + [] G.Window+ G.windowTitle $= title+ G.windowCloseCallback $= exitWith ExitSuccess+ G.windowSizeCallback $= (\size -> G.viewport $= (G.Position 0 0, size))+ G.clearColor $= G.Color4 1 1 1 1+ G.blend $= G.Enabled+ G.blendFunc $= (G.SrcAlpha, G.OneMinusSrcAlpha)+ G.ortho (-dw2) (dw2) (-dh2) (dh2) (-1) 1+ where dw2 = realToFrac $ windowWidth / 2+ dh2 = realToFrac $ windowHeight / 2
+ src/Pure.hs view
@@ -0,0 +1,298 @@+module Pure where++import Data.Monoid+import Data.Maybe+import qualified Physics.Hipmunk as H+import Control.Monad.State++import Control.Applicative+import Data.Tuple(swap)++import Data.List+import Types+import Utils+import Inits+import Graphics++pureGameOver :: Pure -> Bool+pureGameOver s = case pureGameState s of+ On -> False+ _ -> True++processClick :: Pure -> (Pure, [Query])+processClick p = case pureGameState p of+ WaitForClick 0 -> (reset p, [GameOver])+ WaitForClick n -> (p{ pureGameState = WaitForClick (n-1) }, [])+ On -> (p, [])++------------------------------------------------------------------+-- inits++initPure :: Sense -> [Event] -> Pure+initPure sense _ = Pure + { pureScores = initScores + , pureHero = senseHero sense+ , pureBalls = senseBalls sense+ , pureCreation = initCreation+ , pureTouch = Nothing+ , pureGameState = On+ }++initScores = Scores + { scoresLevel = 0+ , scoresLives = livesNum+ , scoresBonus = 0 + }++initCreation = Creation + { creationStat = Stat 0 0 0+ , creationGoalStat = Stat goodBallCount badBallCount bonusBallCount+ , creationTick = 0+ }++-------------------------------------------------------------------+-- events++-- continuous++updateSenses :: Sense -> Pure -> Pure+updateSenses sense pure + | pureGameOver pure = pure+ | otherwise = pure+ { pureHero = senseHero sense+ , pureBalls = senseBalls sense+ , pureCreation= creation{ creationStat = getStat $ senseBalls sense }+ , pureTouch = updTouch =<< pureTouch pure + }+ where creation = pureCreation pure+ getStat = foldl' phi (Stat 0 0 0) . fmap ballType+ phi stat b = case b of + Good -> stat{ goodCount = succ $ goodCount stat }+ Bad -> stat{ badCount = succ $ badCount stat }+ Bonus -> stat{ bonusCount = succ $ bonusCount stat }+ Hero -> stat+ updTouch (n, xs) = case n of+ 0 -> Nothing+ a -> Just (pred a, xs)+++-- discrete++++updateEvents :: [Event] -> Pure -> (Pure, [Query])+updateEvents evts pure + | pureGameOver pure = onGameOver evts pure+ | otherwise = upd pure+ where upd = swap . runState + (concat <$> liftA2 (:) onNothing (mapM onEvent evts)) ++onGameOver :: [Event] -> Pure -> (Pure, [Query])+onGameOver evts pure + | any isUserClick evts = processClick pure+ | otherwise = (pure, [])+ where isUserClick evt = case evt of+ (UserClick _) -> True+ _ -> False+ ++onEvent :: Event -> State Pure [Query]+onEvent = foldEvent onTouch onUserClick++onUserClick :: H.Position -> State Pure [Query]+onUserClick p1 = state $ \s -> + let hero = pureHero s+ v = heroVel $ pureHero s+ p0 = heroPos $ pureHero s+ v1 = H.scale (H.normalize (p1 - p0)) (max v minVel)+ s' = s{ pureHero = hero{ heroVel = H.len v1 }}+ in ([HeroVelocity v1], s')++onNothing :: State Pure [Query]+onNothing = state $ phi+ where phi s + | isGameOver s = ([], setGameOver s) + | pureGameOver s = ([], s)+ | tick == creationPeriod = + (Step : def ++ createBall s, setTick 0 s)+ | otherwise = + (Step : def, setTick (succ tick) s)+ where create = pureCreation s+ tick = creationTick create+ setTick a s = s{ pureCreation = create{ creationTick = a } } + def = removeOutliners s+++setGameOver a = a{ pureGameState = WaitForClick 1 }++isGameOver :: Pure -> Bool+isGameOver s + = (not $ insideFrame $ heroPos $ pureHero s)+ || 0 > (scoresLives $ pureScores s) ++reset :: Pure -> Pure+reset a = a+ { pureScores = initScores+ , pureCreation = initCreation+ , pureGameState= On }+++createBall :: Pure -> [Query]+createBall st = maybeToList $ fmap MakeBall $ freq goal cur+ where goal = creationGoalStat $ pureCreation st+ cur = creationStat $ pureCreation st+++freq :: Stat -> Stat -> Maybe Freq+freq goal cur + | isLess s = Just res+ | otherwise = Nothing+ where dt g = max 0 $ g goal - g cur+ f g = toEnum (g s) / toEnum (total s)+ isLess s = s /= (Stat 0 0 0) ++ s = Stat (dt goodCount) (dt badCount) (dt bonusCount) + res = Freq (f goodCount) (f badCount) (f bonusCount)+ total (Stat a b c) = a + b + c +++removeOutliners :: Pure -> [Query]+removeOutliners = + fmap Remove . filter (not . insideFrame . ballPos) . pureBalls++insideFrame :: H.Position -> Bool+insideFrame (H.Vector x y) = abs x <= w2 && abs y <= h2+ where w2 = windowWidth / 2 + h2 = windowHeight / 2 + +++onTouch :: Ball -> State Pure [Query]+onTouch b = state $ \s -> case ballType b of+ Hero -> ([], s)+ Good -> ([Remove b], updLive (min livesNum . succ) s)+ Bad -> ([], updLive pred s)+ Bonus -> let xs = removeBonus (ballPos b) s+ in (fmap Remove xs, setTouch xs $ + updBonus (length xs) s) ++setTouch xs s = s{ pureTouch = Just (bonusSleep, xs) }++updScores f s = s{ pureScores = f $ pureScores s }+ +updLive f = updScores (\a -> a{ scoresLives = f $ scoresLives a }) ++updCreation f = \a -> a{ pureCreation = f $ pureCreation a } ++updGoalStat f = updCreation $ + \a -> a{ creationGoalStat = f $ creationGoalStat a }+++updBonus :: Int -> Pure -> Pure+updBonus n a + | isLevelUp level' level = updGoalStat (makeItHarder level') a'+ | otherwise = a'+ where (bonus', level') = countBonus n bonus level+ bonus = scoresBonus sco + level = scoresLevel sco + a' = a{ pureScores = sco+ { scoresBonus = bonus'+ , scoresLevel = level'} }+ sco = pureScores a+ isLevelUp new old = new > old+ makeItHarder level a = a+ { badCount = incrBad level $ badCount a+ , bonusCount = incrBonus level $ bonusCount a+ , goodCount = incrGood level $ goodCount a+ }++++{-+updBonus f = updScores (\a -> + let (newBonus, newLevel) = f (scoresBonus a) (scoresLevel a)+ in a{ scoresBonus = newBonus+ , scoresLevel = newLevel+ }) +-}+countBonus n bonus level + | bonus' > bonusNum = (bonus' - bonusNum, level + 1)+ | otherwise = (bonus', level)+ where bonus' = bonus + (fromEnum $ count $ fromIntegral $ n - 1) + count x = 0.5*x*(x + 1)+ +removeBonus :: H.Position -> Pure -> [Ball]+removeBonus pos = filter (closeTo pos . ballPos) . pureBalls+ where closeTo p1 p2 = H.len (p1 - p2) < bonusRadius+++----------------------------------------------------------+-- drawing++picture :: Pure -> Picture+picture a = mconcat [+ drawScores $ pureScores a, + drawWalls, + drawHero $ pureHero a, + mconcat $ fmap drawBall $ pureBalls a,+ maybe mempty (drawTouch $ heroPos $ pureHero a) $ pureTouch a+ ]+++drawHero :: HeroBall -> Picture+drawHero = drawObj Hero . heroPos ++drawBall :: Ball -> Picture+drawBall b = drawObj (ballType b) (ballPos b)++drawObj objType objPos = + Prim (type2color objType) (CircleSolid (vec2point objPos) ballRadius)+ where type2color a = case a of+ Hero -> red+ Good -> green+ Bad -> blue+ Bonus -> orange++drawWalls :: Picture+drawWalls = mconcat $ map f wallPoints + where f (a, b) = Prim (Color 0 0 0) $ Line (vec2point a) (vec2point b)+ +vec2point :: H.Vector -> Point+vec2point (H.Vector x y) = Point x y++scorePosition = Point (-frameWidth/2) (frameHeight/2 + 20)+++drawScores :: Scores -> Picture+drawScores a = mconcat [+ drawBonus a, + drawLives (scoresLives a)]+++drawLives :: Int -> Picture+drawLives n = drawScoresRect livesRect livesNum n (col1 n) (col2 n)+ where col1 n+ | n <= 1 = red+ | otherwise = blue+ col2 n+ | n <= 3 = red+ | otherwise = green++drawScoresRect f lim val col1 col2 = mconcat [+ Prim col2 (uncurry RectSolid $ f $ + fromIntegral (max 0 val) / fromIntegral lim),+ Prim col1 (uncurry Rect $ f 1) ]++ +drawTouch :: H.Position -> (Int, [Ball]) -> Picture+drawTouch center = (rim `mappend`) . mconcat . fmap (drawBall . toBonus) . snd+ where toBonus b = b{ ballType = Bonus }+ rim = Prim orange $ Circle (vec2point center) bonusRadius +++drawBonus :: Scores -> Picture+drawBonus a = Prim black + (Text resultPoint $ "Bonus: " ++ (show $ totalBonus a))++totalBonus :: Scores -> Int+totalBonus a = scoresLevel a * bonusNum + scoresBonus a
+ src/Types.hs view
@@ -0,0 +1,155 @@+module Types where++import Data.Monoid++import IxMap+import Data.IORef+import qualified Physics.Hipmunk as H++type Time = Double++-- actions++data GameState = On | WaitForClick Int++data Query + = Remove Ball + | HeroVelocity H.Velocity | MakeBall Freq+ | GameOver | Step ++-- senses++data Event = Touch Ball | UserClick H.Position++data Sense = Sense + { senseHero :: HeroBall+ , senseBalls :: [Ball] }++-- graphics+ +data Picture = EmptyPicture+ | Prim Color Primitive+ | Join Picture Picture++foldPicture :: a -> (Color -> Primitive -> a) -> (a -> a -> a) + -> Picture -> a+foldPicture emptyPic primPic joinPic p = case p of+ EmptyPicture -> emptyPic+ Prim col a -> primPic col a+ Join a b -> joinPic (f a) (f b)+ where f = foldPicture emptyPic primPic joinPic+++instance Monoid Picture where+ mempty = EmptyPicture+ mappend = Join++data Primitive = Line Point Point + | Circle Point Radius + | Rect Point Point+ | CircleSolid Point Radius + | RectSolid Point Point+ | Text Point String+++data Point = Point Double Double+type Radius = Double ++data Color = Color Double Double Double++------------------------------------------------------++data World = World + { worldPure :: Pure+ , worldDirty :: Dirty }++-- pure++data Pure = Pure+ { pureScores :: Scores+ , pureHero :: HeroBall+ , pureBalls :: [Ball]+ , pureCreation :: Creation+ , pureTouch :: Maybe (Int, [Ball])+ , pureGameState :: GameState+ }++data HeroBall = HeroBall+ { heroPos :: H.Position+ , heroVel :: H.CpFloat+ }+++data Ball = Ball+ { ballType :: BallType+ , ballPos :: H.Position+ , ballId :: Id+ }++data BallType = Hero | Good | Bad | Bonus+ deriving (Show, Eq, Enum)+++type Id = Int++data Scores = Scores + { scoresLevel :: Int+ , scoresLives :: Int+ , scoresBonus :: Int+ } deriving (Show)++data Creation = Creation + { creationStat :: Stat+ , creationGoalStat :: Stat+ , creationTick :: Int+ }++data Stat = Stat+ { goodCount :: Int+ , badCount :: Int+ , bonusCount :: Int+ } deriving (Eq, Show, Read)++data Freq = Freq + { freqGood :: Float+ , freqBad :: Float+ , freqBonus :: Float+ } ++-- dirty++data Dirty = Dirty + { dirtyHero :: Obj+ , dirtyObjs :: IxMap Obj+ , dirtySpace :: H.Space+ , dirtyTouchVar :: Sensor H.Shape+ , dirtyMouse :: Sensor H.Position+ }++data Obj = Obj + { objType :: BallType+ , objShape :: H.Shape+ , objBody :: H.Body+ } deriving (Eq)++type Sensor a = IORef (Maybe a)+++foldQuery :: (Ball -> a) -> (H.Velocity -> a) -> (Freq -> a) + -> a -> a + -> Query -> a+foldQuery rm hv mb go step q = case q of+ Remove ball -> rm ball+ HeroVelocity vel -> hv vel+ MakeBall freq -> mb freq+ GameOver -> go+ Step -> step++foldEvent :: (Ball -> a) -> (H.Position -> a) + -> (Event -> a)+foldEvent touch click a = case a of+ Touch ball -> touch ball+ UserClick p -> click p+++
+ src/Utils.hs view
@@ -0,0 +1,22 @@+module Utils where++import qualified Physics.Hipmunk as H+import qualified Graphics.Rendering.OpenGL as G+import Types++vec :: H.CpFloat -> H.CpFloat -> H.Vector+vec = H.Vector++un :: a +un = undefined++d2gl :: Double -> G.GLfloat+d2gl = realToFrac++d2gli :: Double -> G.GLsizei+d2gli = toEnum . fromEnum . d2gl+++vertex2f :: G.GLfloat -> G.GLfloat -> IO ()+vertex2f a b = G.vertex (G.Vertex3 a b 0)+
+ src/World.hs view
@@ -0,0 +1,58 @@+module World where++import qualified Physics.Hipmunk as H+import qualified Graphics.UI.GLFW as G++import Data.StateVar++import Control.Monad+import Data.Maybe+import Types+import Utils ++import qualified IxMap as M++import Pure+import Dirty+import Inits+import Graphics++updateWorld :: World -> IO (World, Time)+updateWorld world = do+ t0 <- get G.time+ (sense, events) <- percept dirty+ let (pure', queries) = updatePure sense events pure+ dirty' <- react queries dirty + t1 <- get G.time+ return (World pure' dirty', t1 - t0)+ where dirty = worldDirty world+ pure = worldPure world ++percept :: Dirty -> IO (Sense, [Event])+percept a = do+ hero <- obj2hero $ dirtyHero a+ balls <- mapM (uncurry obj2ball) $ M.toList $ dirtyObjs a+ evts1 <- fmap maybeToList $ getTouch (dirtyTouchVar a) $ dirtyObjs a+ evts2 <- fmap maybeToList $ getClick $ dirtyMouse a+ return $ (Sense hero balls, evts1 ++ evts2)+++updatePure :: Sense -> [Event] -> Pure -> (Pure, [Query])+updatePure s evts = updateEvents evts . updateSenses s +++react :: [Query] -> Dirty -> IO Dirty+react = foldr (<=<) return + . fmap (foldQuery removeBall heroVelocity + makeBall gameOver (stepDirty dt))+++drawWorld :: World -> IO ()+drawWorld = draw . picture . worldPure+++initWorld :: IO World+initWorld = do+ dirty <- initDirty+ (sense, events) <- percept dirty+ return $ World (initPure sense events) dirty