Monaris 0.1.3 → 0.1.4
raw patch · 2 files changed
+100/−114 lines, 2 files
Files
- Monaris.cabal +5/−1
- Monaris.hs +95/−113
Monaris.cabal view
@@ -1,5 +1,5 @@ name: Monaris -version: 0.1.3 +version: 0.1.4 synopsis: A simple tetris clone description: A tetris clone written in Haskell. homepage: https://github.com/fumieval/Monaris/ @@ -12,6 +12,10 @@ build-type: Simple cabal-version: >=1.8 data-files: images/*.png + +source-repository head + type: git + location: https://github.com/fumieval/Monaris.git executable Monaris main-is: Monaris.hs
Monaris.hs view
@@ -3,6 +3,7 @@ import Control.Monad import Control.Monad.State import Control.Monad.Reader +import Control.Monad.Free import Data.List import Data.Function import Data.Array @@ -10,45 +11,37 @@ import Data.Maybe import Data.Vect import qualified Data.Map as M -import Control.Monad.Free import System.Directory import Graphics.FreeGame import Paths_Monaris +type Field = Array Coord (Maybe BlockColor) +type BlockColor = Int type Coord = (Int, Int) -(a, b) #+# (c, d) = (a + c, b + d) -(a, b) #-# (c, d) = (a - c, b - d) -k *# (a, b) = (k * a, k * b) -(a, b) #/ k = (div a k, div b k) - -data Color = Red | Yellow | Green | Cyan | Blue | Magenta | Orange deriving (Eq, Ord, Enum) - type Polyomino = [Coord] -polyominos = [([(0,0),(0,1),(0,2),(0,3)], Cyan) - ,([(0,0),(0,1),(1,0),(1,1)], Yellow) - ,([(0,0),(0,1),(0,2),(1,2)], Orange) - ,([(0,0),(0,1),(0,2),(-1,2)], Blue) - ,([(0,0),(0,1),(1,1),(1,2)], Green) - ,([(0,0),(0,1),(-1,1),(-1,2)], Red) - ,([(0,0),(-1,0),(1,0),(0,1)], Magenta)] - -translate :: Coord -> Polyomino -> Polyomino -translate = map . (#+#) +pair f (x, y) = (f x, f y) +pair2 f (a, b) (c, d) = (f a c, f b d) -type Field = Array Coord (Maybe Color) +polyominos = [([(0,0),(0,1),(0,2),(0,3)], 3) + ,([(0,0),(0,1),(1,0),(1,1)], 1) + ,([(0,0),(0,1),(0,2),(1,2)], 6) + ,([(0,0),(0,1),(0,2),(-1,2)], 4) + ,([(0,0),(0,1),(1,1),(1,2)], 2) + ,([(0,0),(0,1),(-1,1),(-1,2)], 0) + ,([(0,0),(-1,0),(1,0),(0,1)], 5)] -data Spin = CCW | CW deriving (Show, Eq, Ord) +translate :: Coord -> Polyomino -> Polyomino +translate = map . pair2 (+) -spin :: Spin -> Coord -> Polyomino -> Polyomino -spin CCW center = map $ (#/2) . (#+#center) . (\(x, y) -> (-y, x)) . (#-#center) . (2*#) -spin CW center = map $ (#/2) . (#+#center) . (\(x, y) -> (y, -x)) . (#-#center) . (2*#) +spin :: (Coord -> Coord) -> Coord -> Polyomino -> Polyomino +spin t center = map $ pair (`div`2) . pair2 (+) center . t . pair2 subtract center . pair (2*) where centers :: Polyomino -> [Coord] -centers cs = cs' ++ [i | i@(c, r) <- map ((1,1)#+#) cs' +centers cs = cs' ++ [i | i@(c, r) <- map (pair2 (+) (1,1)) cs' , let c0 = minimum (map fst cs'), let c1 = maximum (map fst cs') , let r0 = minimum (map snd cs'), let r1 = maximum (map snd cs') - , c0 < c && c < c1, r0 < r && r < r1] where cs' = map (2*#) cs + , c0 < c && c < c1, r0 < r && r < r1] where cs' = map (pair (2*)) cs completeLines :: Field -> [Int] completeLines field = [r | r <- [r0..r1], all isJust [field ! (c, r) | c <- [c0..c1]]] where @@ -61,23 +54,22 @@ | otherwise = a] where bnd@((_, r0), _) = bounds field -putToField :: Color -> Field -> Polyomino -> Maybe Field +putToField :: BlockColor -> Field -> Polyomino -> Maybe Field putToField color field omino = [field // map (,Just color) omino | all ((&&) <$> inRange (bounds field) <*> fmap isNothing (field !)) omino] -getPolyomino :: Game (Polyomino, Color) +getPolyomino :: Game (Polyomino, BlockColor) getPolyomino = (polyominos!!) <$> randomness (0, length polyominos - 1) spinStrategy :: Polyomino -> Field -> [Polyomino] -> Polyomino spinStrategy original field = maximumBy (compare `on` ev) where g xs = fromIntegral (sum (map snd xs)) / fromIntegral (length xs) ev x = sum [fromEnum (g original <= g x) - + sum [1 | c <- neighbors, not (inRange (bounds field) c) || isJust (field ! c)] ^ 2 - | r <- nub $ map snd x] - where neighbors = nub $ (#+#) <$> x <*> [(0, 1), (0, -1), (1, 0), (1, 1)] + + sum [1 | c <- neighbors, not (inRange (bounds field) c) || isJust (field ! c)] ^ 2 + | r <- nub $ map snd x] + where neighbors = nub $ pair2 (+) <$> x <*> [(0, 1), (0, -1), (1, 0), (1, 1)] -place :: (?picBlocks :: M.Map (Color, Int) Picture, ?blockSize :: Float, ?picBlockBackground :: Picture) - => Polyomino -> Color -> Field -> Int -> Game (Maybe Field) +place :: (?env :: Environment) => Polyomino -> BlockColor -> Field -> Int -> Game (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) @@ -109,8 +101,8 @@ (False, True) -> move (1, 0) _ -> return False b <- case (not z && z', not x && x') of - (True, False) -> sp CCW - (False, True) -> sp CW + (True, False) -> sp (\(x, y) -> (-y, x)) + (False, True) -> sp (\(x, y) -> (y, -x)) _ -> return False return $ a || b @@ -150,43 +142,20 @@ | otherwise = destination omino' where omino' = translate (0, 1) omino -eliminate :: (?picBlocks :: M.Map (Color, Int) Picture, ?blockSize :: Float, ?picBlockBackground :: Picture) - => Field -> Game (Field, Int) +eliminate :: (?env :: Environment) => Field -> Game (Field, Int) eliminate field = do - when (not.null $ rows) $ forM_ [0..5] $ \i -> replicateM_ 2 $ draw i >> tick + 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 - $ \(_, r) color -> ?picBlocks M.! (color, if r `elem` rows then n else 0) - -gameOver :: (?picBlocks :: M.Map (Color, Int) Picture, ?blockSize :: Float) => Field -> Game () -gameOver field = do - let pics = [Translate pos (?picBlocks M.! (p, 0)) | (ix@(c, r), color) <- assocs field - , let pos = ?blockSize *& Vec2 (fromIntegral c) (fromIntegral r) - , p <- maybeToList color] - objs <- forM pics $ \pic -> do - dx <- randomness (-1,1) - return (zero, Vec2 dx (-3), pic) - run 120 objs - where - update (pos, v, pic) = drawPicture (Translate pos pic) - >> return (pos &+ v, v &+ Vec2 0 0.2, pic) - run 0 _ = return () - run n objs = do - objs' <- mapM update objs - tick - run (n - 1) objs' + $ \(_, r) color -> picBlocks ?env M.! (color, if r `elem` rows then n else 0) -gameMain :: (?blockSize :: Float, ?picBlocks :: M.Map (Color, Int) Picture - , ?picCharWidth :: Float , ?picChars :: M.Map Char Picture - , ?picBackground :: Picture, ?picBlockBackground :: Picture - , ?highScore :: Int) - => Field -> Int -> Float -> (Polyomino, Color) -> (Polyomino, Color) -> Game Int +gameMain :: (?env :: Environment, ?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/50)) + r <- embed $ place omino color field (floor $ 60 * 2**(-line/40)) case r of - Nothing -> embed (gameOver field) >> return total + Nothing -> total <$ embed (gameOver field) Just field' -> do (field'', n) <- embed $ eliminate field' next' <- getPolyomino @@ -195,7 +164,7 @@ embed (Pure a) = return a embed m = do let drawTo x y = drawPicture . Translate (Vec2 x y) - drawTo 320 240 ?picBackground + drawTo 320 240 $ picBackground ?env cont <- hoistFree (transPicture $ Translate (Vec2 24 24)) $ do drawPicture $ renderFieldBackground field untickGame m @@ -205,76 +174,89 @@ tick embed cont -gameTitle :: (?picCharWidth :: Float, ?picChars :: M.Map Char Picture, ?picTitle :: Picture, ?highScore :: Int) - => Game () +gameTitle :: (?env :: Environment, ?highScore :: Int) => Game () gameTitle = do z <- askInput (KeyChar 'Z') - drawPicture $ Translate (Vec2 320 240) ?picTitle - drawPicture $ Translate (Vec2 490 182) $ renderString (show ?highScore) + drawPicture $ Translate (Vec2 320 240) (picTitle ?env) + drawPicture $ Translate (Vec2 490 182) $ renderString $ show ?highScore tick - when (not z) gameTitle - return () + unless z gameTitle -renderFieldBackground :: (?picBlockBackground :: Picture, ?blockSize :: Float) => Field -> Picture -renderFieldBackground field = Pictures $ [Translate pos ?picBlockBackground - | (c, r) <- indices field, r >= 0 - , let pos = ?blockSize *& Vec2 (fromIntegral c) (fromIntegral r)] +blockPos :: (?env :: Environment) => Int -> Int -> Vec2 +blockPos c r = blockSize ?env *& Vec2 (fromIntegral c) (fromIntegral r) -renderField :: (?picBlocks :: M.Map (Color, Int) Picture, ?blockSize :: Float, ?picBlockBackground :: Picture) - => Field -> Picture -renderField = renderFieldBy $ \_ color -> ?picBlocks M.! (color, 0) +gameOver :: (?env :: Environment) => Field -> Game () +gameOver field = do + let pics = [Translate (blockPos c r) (picBlocks ?env 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) + void $ foldM run objs [1..120] + where + update (pos, v, pic) = (pos &+ v, v &+ Vec2 0 0.2, pic) <$ drawPicture (Translate pos pic) + run objs = const $ mapM update objs <* tick -renderFieldBy :: (?blockSize :: Float) - => (Coord -> Color -> Picture) -> Field -> Picture -renderFieldBy f field = Pictures $ [Translate pos pic - | (ix@(c, r), color) <- assocs field - , r >= 0, let pos = ?blockSize *& Vec2 (fromIntegral c) (fromIntegral r) - , pic <- maybeToList (f ix <$> color)] +renderFieldBackground :: (?env :: Environment) => Field -> Picture +renderFieldBackground field = Pictures [blockPos c r `Translate` picBlockBackground ?env | (c, r) <- indices field, r >= 0] -renderPolyomino :: (?picBlocks :: M.Map (Color, Int) Picture, ?blockSize :: Float) - => Int -> Polyomino -> Color -> Picture -renderPolyomino i omino color = Pictures [Translate pos (?picBlocks M.! (color, i)) - | (c, r) <- omino, r >= 0, let pos = ?blockSize *& Vec2 (fromIntegral c) (fromIntegral r)] +renderField :: (?env :: Environment) => Field -> Picture +renderField = renderFieldBy $ \_ color -> picBlocks ?env M.! (color, 0) -renderString :: (?picCharWidth :: Float, ?picChars :: M.Map Char Picture) => String -> Picture -renderString str = Pictures [Translate (Vec2 (?picCharWidth * i) 0) $ ?picChars M.! ch - | (i, ch) <- zip [0..] str] +renderFieldBy :: (?env :: Environment) => (Coord -> BlockColor -> Picture) -> Field -> Picture +renderFieldBy f field = Pictures [blockPos c r `Translate` pic + | (ix@(c, r), color) <- assocs field, r >= 0, pic <- maybeToList $ f ix <$> color] +renderPolyomino :: (?env :: Environment) => Int -> Polyomino -> BlockColor -> Picture +renderPolyomino i omino color = Pictures [blockPos c r `Translate` (picBlocks ?env M.! (color, i)) + | (c, r) <- omino, r >= 0] + +renderString :: (?env :: Environment) => String -> Picture +renderString str = Pictures [Vec2 (picCharWidth ?env * i) 0 `Translate` (picChars ?env M.! ch) | (i, ch) <- zip [0..] str] + +data Environment = Environment + { picBlocks :: M.Map (BlockColor, Int) Picture + , picChars :: M.Map Char Picture + , picBlockBackground :: Picture + , picBackground :: Picture + , picTitle :: Picture + , blockSize :: Float + , picCharWidth :: Float + } + main :: IO () main = void $ runGame (defaultGameParam {windowTitle="Monaris"}) $ do - let colors = enumFrom Red - initialField = listArray ((0,-4), (9,18)) (repeat Nothing) + let initialField = listArray ((0,-4), (9,18)) (repeat Nothing) load path = embedIO $ getDataFileName path >>= loadBitmapFromFile - imgChars <- load "images/numbers.png" - picChars' <- liftM M.fromAscList $ forM [0..9] - $ \n -> (,) (intToDigit n) <$> loadPicture (cropBitmap imgChars (24, 32) (n * 24, 0)) - imgBlocks <- load "images/Block.png" - picBlocks' <- liftM M.fromAscList $ forM ((,) <$> zip [0..] colors <*> [0..7]) - $ \((i, color), j) -> (,) (color, j) <$> loadPicture (cropBitmap imgBlocks (48, 48) (i * 48, j * 48)) + imgChars <- load "images/numbers.png" + imgBlocks <- load "images/Block.png" + imgBackground <- load "images/background.png" + imgBlockBackground <- load "images/block-background.png" + imgTitle <- load "images/title.png" - imgBackground <- load "images/background.png" >>= loadPicture - imgBlockBackground <- load "images/block-background.png" >>= loadPicture - - imgTitle <- load "images/title.png" >>= loadPicture highscorePath <- embedIO $ (++"/.monaris_highscore") <$> getHomeDirectory - let ?picCharWidth = 18 - ?picChars = picChars' - ?blockSize = 24 - ?picBlocks = picBlocks' - ?picBackground = imgBackground - ?picBlockBackground = imgBlockBackground - ?picTitle = imgTitle + let ?env = Environment + (M.fromAscList [((i, j), BitmapPicture $ cropBitmap imgBlocks (48, 48) (i * 48, j * 48)) + | i <- [0..6], j <- [0..7]]) + (M.fromAscList [(intToDigit n, BitmapPicture $ cropBitmap imgChars (24, 32) (n * 24, 0)) + | n <- [0..9]]) + (BitmapPicture imgBlockBackground) + (BitmapPicture imgBackground) + (BitmapPicture imgTitle) + 24 + 24 let loop h = do let ?highScore = h - _ <- gameTitle + gameTitle + score <- join $ gameMain initialField 0 0 <$> getPolyomino <*> getPolyomino when (?highScore < score) $ embedIO $ writeFile highscorePath (show score) - loop (max score ?highScore) + + loop (max score h) f <- embedIO $ doesFileExist highscorePath - score <- if f then embedIO $ read <$> readFile highscorePath else return 0 - loop score + (if f then embedIO $ read <$> readFile highscorePath else return 0) >>= loop