Monaris 0.1.5 → 0.1.6
raw patch · 2 files changed
+49/−49 lines, 2 filesdep −vectdep ~free-game
Dependencies removed: vect
Dependency ranges changed: free-game
Files
- Monaris.cabal +2/−2
- Monaris.hs +47/−47
Monaris.cabal view
@@ -1,5 +1,5 @@ name: Monaris -version: 0.1.5 +version: 0.1.6 synopsis: A simple tetris clone description: A tetris clone written in Haskell. homepage: https://github.com/fumieval/Monaris/ @@ -20,4 +20,4 @@ executable Monaris main-is: Monaris.hs -- other-modules: - build-depends: base ==4.*, mtl >=2.1, array >=0.4, vect >=0.4, containers >=0.4, free >=3.0, directory >=1.1, free-game >= 0.3.2.6 && < 0.4+ build-depends: base ==4.*, mtl >=2.1, array >=0.4, containers >=0.4, free >=3.0, directory >=1.1, free-game == 0.9.*
Monaris.hs view
@@ -9,20 +9,19 @@ import Data.Array import Data.Char import Data.Maybe -import Data.Vect import qualified Data.Map as M import System.Directory -import Graphics.FreeGame +import Graphics.UI.FreeGame import Paths_Monaris loadBitmapsWith 'getDataFileName "images" -picBlocks :: M.Map (Int, Int) Picture -picBlocks = M.fromAscList [((i, j), Bitmap $ cropBitmap _blocks_png (48, 48) (i * 48, j * 48)) +picBlocks :: Picture2D m => M.Map (Int, Int) (m ()) +picBlocks = M.fromAscList [((i, j), fromBitmap $ cropBitmap _blocks_png (48, 48) (i * 48, j * 48)) | i <- [0..6], j <- [0..7]] -picChars :: M.Map Char Picture -picChars = M.fromAscList [(intToDigit n, Bitmap $ cropBitmap _numbers_png (24, 32) (n * 24, 0)) +picChars :: Picture2D m => M.Map Char (m ()) +picChars = M.fromAscList [(intToDigit n, fromBitmap $ cropBitmap _numbers_png (24, 32) (n * 24, 0)) | n <- [0..9]] blockSize, picCharWidth :: Float @@ -46,8 +45,8 @@ ,([(0,0),(0,1),(-1,1),(-1,2)], 0) ,([(0,0),(-1,0),(1,0),(0,1)], 5)] -translate :: Coord -> Polyomino -> Polyomino -translate = map . pair2 (+) +translateP :: Coord -> Polyomino -> Polyomino +translateP = map . pair2 (+) spin :: (Coord -> Coord) -> Coord -> Polyomino -> Polyomino spin t center = map $ pair (`div`2) . pair2 (+) center . t . pair2 subtract center . pair (2*) where @@ -84,26 +83,28 @@ | r <- nub $ map snd x] where neighbors = nub $ pair2 (+) <$> x <*> [(0, 1), (0, -1), (1, 0), (1, 1)] -place :: Polyomino -> BlockColor -> Field -> Int -> Game (Maybe Field) +place :: Polyomino -> BlockColor -> Field -> Int -> Free GUI (Maybe Field) place polyomino color field period = do if or [isJust $ field ! (c, r) | (c, r) <- range ((c0, r0), (c1, -1))] then return Nothing else run 1 (Left 0) (False, False, False, False, False, False) - `evalStateT` translate (5, -1 - maximum (map snd polyomino)) polyomino + `evalStateT` translateP (5, -1 - maximum (map snd polyomino)) polyomino where ((c0, r0), (c1, r1)) = bounds field putF = putToField color field run t param ks = do - [l',r',u',d',z',x'] <- lift $ mapM getButtonState [KeyLeft, KeyRight, KeyUp, KeyDown, KeyChar 'Z', KeyChar 'X'] + [l',r',u',d'] <- mapM keySpecial [KeyLeft, KeyRight, KeyUp, KeyDown] + z' <- keyChar 'Z' + x' <- keyChar 'X' when (t `mod` period == 0) $ void $ move (0, 1) omino <- get param' <- flip runReaderT (ks, (l',r',u',d',z',x')) - $ if isNothing $ putF $ translate (0, 1) omino + $ if isNothing $ putF $ translateP (0, 1) omino then fmap Right <$> handleLanding (either (const (60, 120)) id param) else fmap Left <$> handleNotLanding (either id (const 0) param) - drawPicture $ renderField field - drawPicture $ renderPolyomino 0 omino color + renderField field + renderPolyomino 0 omino color case param' of Just p -> tick >> run (succ t) p (l',r',u',d',z',x') Nothing -> return (putF omino) @@ -124,7 +125,7 @@ handleLanding (play, playBound) = do ((_,_,u,d,_,_),(_,_,u',d',_,_)) <- ask omino <- get - drawPicture $ renderPolyomino 7 omino color + renderPolyomino 7 omino color if not u && u' || not d && d' then return Nothing else do f <- handleCommon return $ Just $ if f then (playBound / 2, playBound - 10) else (play - 1, playBound) @@ -133,7 +134,7 @@ _ <- handleCommon ((_,_,u,_,_,_),(_,_,u',d',_,_)) <- ask omino <- get - drawPicture $ renderPolyomino 6 (destination omino) color + renderPolyomino 6 (destination omino) color when (not u && u') $ modify destination if d' then do @@ -141,7 +142,7 @@ return (Just (succ t)) else return (Just 0) - move dir = do omino <- translate dir <$> get + move dir = do omino <- translateP dir <$> get if isJust $ putF omino then put omino >> return True else return False @@ -154,20 +155,20 @@ destination omino | isNothing $ putF omino' = omino | otherwise = destination omino' - where omino' = translate (0, 1) omino + where omino' = translateP (0, 1) omino -eliminate :: Field -> Game (Field, Int) +eliminate :: Field -> Free GUI (Field, Int) eliminate field = do unless (null rows) $ forM_ [0..5] $ \i -> replicateM_ 2 $ draw i >> tick return (foldl deleteLine field rows, length rows) where rows = completeLines field - draw n = drawPicture $ flip renderFieldBy field + draw n = flip renderFieldBy field $ \(_, r) color -> picBlocks M.! (color, if r `elem` rows then n else 0) gameMain :: (?highScore :: Int) => Field -> Int -> Float -> (Polyomino, BlockColor) -> (Polyomino, BlockColor) -> Game Int gameMain field total line (omino, color) next = do - r <- embed $ place omino color field (floor $ 60 * 2**(-line/40)) + r <- embed $ place omino color field (floor $ 50 * 2 ** (-line/30)) case r of Nothing -> total <$ embed (gameOver field) Just field' -> do @@ -177,59 +178,58 @@ where embed (Pure a) = return a embed m = do - let drawTo x y = drawPicture . Translate (Vec2 x y) - drawTo 320 240 $ Bitmap _background_png - cont <- hoistFree (transPicture $ Translate (Vec2 24 24)) $ do - drawPicture $ renderFieldBackground field + translate (V2 320 240) $ fromBitmap _background_png + cont <- translate (V2 24 24) $ do + renderFieldBackground field untick m - drawTo 480 133 $ renderString $ show total - drawTo 480 166 $ renderString $ show ?highScore - drawTo 500 220 $ uncurry (renderPolyomino 0) next + translate (V2 480 133) $ renderString $ show total + translate (V2 480 166) $ renderString $ show ?highScore + translate (V2 500 220) $ uncurry (renderPolyomino 0) next tick embed $ either id Pure cont gameTitle :: (?highScore :: Int) => Game () gameTitle = do - z <- getButtonState (KeyChar 'Z') - drawPicture $ Translate (Vec2 320 240) (Bitmap _title_png) - drawPicture $ Translate (Vec2 490 182) $ renderString $ show ?highScore + z <- keyChar 'Z' + translate (V2 320 240) (fromBitmap _title_png) + translate (V2 490 182) $ renderString $ show ?highScore tick unless z gameTitle -blockPos :: Int -> Int -> Vec2 -blockPos c r = blockSize *& Vec2 (fromIntegral c) (fromIntegral r) +blockPos :: Int -> Int -> V2 Float +blockPos c r = blockSize *^ fmap fromIntegral (V2 c r) -gameOver :: Field -> Game () +gameOver :: Field -> Free GUI () gameOver field = do - let pics = [Translate (blockPos c r) (picBlocks M.! (p, 0)) + let pics = [translate (blockPos c r) (picBlocks M.! (p, 0)) | ((c, r), color) <- assocs field, p <- maybeToList color] objs <- forM pics $ \pic -> do dx <- randomness (-1,1) - return (zero, Vec2 dx (-3), pic) + return (zero, V2 dx (-3), pic) void $ foldM run objs [1..120] where - update (pos, v, pic) = (pos &+ v, v &+ Vec2 0 0.2, pic) <$ drawPicture (Translate pos pic) + update (pos, v, pic) = (pos ^+^ v, v ^+^ V2 0 0.2, pic) <$ translate pos pic run objs = const $ mapM update objs <* tick -renderFieldBackground :: Field -> Picture -renderFieldBackground field = Pictures [blockPos c r `Translate` Bitmap _block_background_png | (c, r) <- indices field, r >= 0] +renderFieldBackground :: (Monad m, Picture2D m) => Field -> m () +renderFieldBackground field = sequence_ [blockPos c r `translate` fromBitmap _block_background_png | (c, r) <- indices field, r >= 0] -renderField :: Field -> Picture +renderField :: (Monad m, Picture2D m) => Field -> m () renderField = renderFieldBy $ \_ color -> picBlocks M.! (color, 0) -renderFieldBy :: (Coord -> BlockColor -> Picture) -> Field -> Picture -renderFieldBy f field = Pictures [blockPos c r `Translate` pic +renderFieldBy :: (Monad m, Picture2D m) => (Coord -> BlockColor -> m ()) -> Field -> m () +renderFieldBy f field = sequence_ [blockPos c r `translate` pic | (ix@(c, r), color) <- assocs field, r >= 0, pic <- maybeToList $ f ix <$> color] -renderPolyomino :: Int -> Polyomino -> BlockColor -> Picture -renderPolyomino i omino color = Pictures [blockPos c r `Translate` picBlocks M.! (color, i) +renderPolyomino :: (Monad m, Picture2D m) => Int -> Polyomino -> BlockColor -> m () +renderPolyomino i omino color = sequence_ [blockPos c r `translate` picBlocks M.! (color, i) | (c, r) <- omino, r >= 0] -renderString :: String -> Picture -renderString str = Pictures [Vec2 (picCharWidth * i) 0 `Translate` picChars M.! ch | (i, ch) <- zip [0..] str] +renderString :: (Monad m, Picture2D m) => String -> m () +renderString str = sequence_ [V2 (picCharWidth * i) 0 `translate` picChars M.! ch | (i, ch) <- zip [0..] str] main :: IO () -main = void $ runGame (defaultGameParam {windowTitle="Monaris"}) $ do +main = void $ runGame (def {_windowTitle = "Monaris"}) $ do let initialField = listArray ((0,-4), (9,18)) (repeat Nothing) highscorePath <- embedIO $ (++"/.monaris_highscore") <$> getHomeDirectory let loop h = do