diff --git a/click-clack.cabal b/click-clack.cabal --- a/click-clack.cabal +++ b/click-clack.cabal @@ -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 + + + + + + diff --git a/src/Dirty.hs b/src/Dirty.hs new file mode 100644 --- /dev/null +++ b/src/Dirty.hs @@ -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 () + + diff --git a/src/Graphics.hs b/src/Graphics.hs new file mode 100644 --- /dev/null +++ b/src/Graphics.hs @@ -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 + + + + diff --git a/src/Inits.hs b/src/Inits.hs new file mode 100644 --- /dev/null +++ b/src/Inits.hs @@ -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 + + diff --git a/src/IxMap.hs b/src/IxMap.hs new file mode 100644 --- /dev/null +++ b/src/IxMap.hs @@ -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 + + diff --git a/src/Loop.hs b/src/Loop.hs new file mode 100644 --- /dev/null +++ b/src/Loop.hs @@ -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 diff --git a/src/Pure.hs b/src/Pure.hs new file mode 100644 --- /dev/null +++ b/src/Pure.hs @@ -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 diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 --- /dev/null +++ b/src/Types.hs @@ -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 + + + diff --git a/src/Utils.hs b/src/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Utils.hs @@ -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) + diff --git a/src/World.hs b/src/World.hs new file mode 100644 --- /dev/null +++ b/src/World.hs @@ -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