tateti-tateti (empty) → 0.1.0.0
raw patch · 8 files changed
+601/−0 lines, 8 filesdep +arraydep +basedep +lens-simplesetup-changed
Dependencies added: array, base, lens-simple, mtl, ncurses, random
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- src/Draw.hs +86/−0
- src/Main.hs +218/−0
- src/OtherScreens.hs +75/−0
- src/Types.hs +82/−0
- src/Util.hs +75/−0
- tateti-tateti.cabal +33/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Ezequiel Alvarez (c) 2015++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Ezequiel Alvarez nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Draw.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE LambdaCase #-}+module Draw where++import Control.Monad+import Data.Array+import Lens.Simple+import UI.NCurses++import Types+import Util+++drawCrosses :: GameState -> Colors -> Update ()+drawCrosses gs colors = do+ -- main cross+ drawCross 7 Nothing (0, 0)++ -- top row crosses+ let offsets = [1, 1 + 8, 1 + 8 + 8]+ coords = (,) <$> offsets <*> offsets+ poss = range (Position T L, Position B R)+ winner p = gs ^. gBoardState . bsAx p . bsWinner+ color_ids = map (winner >=> return . colors . color) poss++ mapM_ (uncurry $ drawCross 1) $ zip color_ids coords+++drawCross :: Integer -> Maybe ColorID -> (Integer, Integer) -> Update ()+drawCross cellsize m_cid (y, x) = do+ case m_cid of+ Just cid -> setColor cid+ Nothing -> setColor defaultColorID++ moveCursor (cellsize + y) x+ drawLineH (Just glyphLineH) (cellsize * 3 + 2)+ moveCursor (cellsize + y + cellsize + 1) x+ drawLineH (Just glyphLineH) (cellsize * 3 + 2)++ moveCursor y (cellsize + x)+ drawLineV (Just glyphLineV) (cellsize * 3 + 2)+ moveCursor y (cellsize + x + cellsize + 1)+ drawLineV (Just glyphLineV) (cellsize * 3 + 2)++ setColor defaultColorID+++drawMessages :: GameState -> Colors -> Update ()+drawMessages gs colors = do++ let mode = gs ^. gMode+ moveCursor 0 2+ clearLine+ drawString "Mode: "+ setColor . colors . color $ mode+ drawString (show $ mode)+ setColor defaultColorID++ let player = gs ^. gPlayer+ moveCursor 1 2+ drawString "Player: "+ setColor . colors . color $ player+ drawString $ show player+ setColor defaultColorID+++drawCursor :: GameState -> Update ()+drawCursor gs =+ let p = gs ^. gBoardState . bsPosition+ p' = gs ^. gBoardState . bsCells . ax p . bsPosition+ in+ uncurry moveCursor $ positionToCoordinates p p'+++drawMarks :: GameState -> Colors -> Update ()+drawMarks gs colors = do+ let poss = range (Position T L, Position B R)+ forM_ poss $ \p -> do+ let poss' = range (Position T L, Position B R)+ forM_ poss' $ \p' -> do+ let m_p = gs ^. gBoardState . bsAx p . bsAx p'+ case m_p of+ Nothing -> return ()+ Just player -> do+ uncurry moveCursor $ positionToCoordinates p p'+ setColor . colors . color $ player+ drawString $ show player
+ src/Main.hs view
@@ -0,0 +1,218 @@+{-# LANGUAGE LambdaCase, FlexibleContexts #-}+module Main where++import Control.Monad.Trans+import Control.Monad.State.Strict+import Data.Array+import Data.Maybe+import Lens.Simple+import UI.NCurses+import System.Random++import OtherScreens+import Types+import Draw+import Util++main :: IO ()+main =+ let game = GameState { _gPlayer=X+ , _gBoardState=defaultBoard (+ defaultBoard Nothing)+ , _gMode = Free+ , _gQuit = False }+ in+ void . runCurses . flip runStateT game $ do+ lift $ setEcho False+ -- main window+ w1 <- lift $ newWindow 23 23 1 1+ -- message window+ w2 <- lift $ newWindow 3 15 (24 - 2) 24++ colors <- getColors++ whoPlaysLoop w1 colors (CPlayer X) >>= \case+ -- quited+ Nothing -> return ()+ -- chose something+ Just m_choice -> do+ pl <- case m_choice of+ CPlayer pl -> return pl+ CRandom -> do+ n <- liftIO randomIO :: Game Int+ if n < 0+ then return X+ else return O+ gPlayer .= pl+ lift $ updateWindow w1 clear++ m_winner <- mainLoop w1 w2 colors++ case m_winner of+ Nothing -> return ()+ Just winner -> do+ lift $ updateWindow w2 clear+ endGameLoop winner w2 colors++ -- cleaning up+ lift $ closeWindow w1+ lift $ closeWindow w2+++mainLoop :: Window -> Window -> Colors -> Game (Maybe Winner)+mainLoop w1 w2 colors = do+ gs <- get+ lift $ updateWindow w1 $ drawCrosses gs colors+ lift $ updateWindow w2 $ drawMessages gs colors+ lift $ updateWindow w1 $ drawMarks gs colors+ lift $ updateWindow w1 $ drawCursor gs++ lift render++ parseInput w1 >>= \case+ Movement m -> movePlayer m+ Select -> use gMode >>= \case+ Free -> do+ p <- use (gBoardState . bsPosition)+ use (gBoardState . bsAx p . bsWinner) >>= \case+ -- board is already closed, do nothing+ Just _ -> return ()+ -- board is open, enter+ Nothing -> gMode .= Fixed+ Fixed -> actionPlayer >>= \case+ -- illegal action, do noting+ Nothing -> return ()++ -- legal action, `played_p` is where they played+ Just played_p -> do++ -- calculate winners+ p <- use (gBoardState . bsPosition)+ gBoardState . bsAx p . bsWinner <~ innerWinner played_p++ gBoardState . bsWinner <~ outerWinner p++ -- switch players+ gPlayer %= \x -> if x == X then O else X++ -- move to next board+ gBoardState . bsPosition .= played_p+ p' <- use (gBoardState . bsPosition)++ -- enter free mode if closed+ use (gBoardState . bsAx p' . bsWinner) >>= \case+ Nothing -> return ()+ Just _ -> gMode .= Free+ Quit -> gQuit .= True++ use gQuit >>= \case+ True -> return Nothing+ False -> use (gBoardState . bsWinner) >>= \case+ Nothing -> mainLoop w1 w2 colors+ winner -> return winner+ where+ innerWinner played_p = do+ pl <- use gPlayer+ p <- use (gBoardState . bsPosition)+ cells <- use (gBoardState . bsAx p . bsCells)+ return $ calcWinners cells played_p pl (==Just pl) isJust++ outerWinner p = do+ pl <- use gPlayer+ cells <- use (gBoardState . bsCells)+ return $ calcWinners cells p pl+ (\x -> x ^. bsWinner == Just (Player pl))+ (\x -> isJust $ x ^. bsWinner)+++-- | Acts on a user marking a cell, on success returns which position.+actionPlayer :: Game (Maybe Position)+actionPlayer = do+ pl <- use gPlayer++ -- check empty space+ pos <- use (gBoardState . bsPosition)++ zoom (gBoardState . bsAx pos) $ do++ pos' <- use bsPosition++ use (bsAx pos') >>= \case+ -- the spot is already occupied+ Just _ -> return Nothing++ -- the spot is free+ Nothing -> do+ bsAx pos' .= Just pl+ return $ Just pos'+++movePlayer :: Movement -> Game ()+movePlayer input = do+ use gMode >>= \case+ Free -> do+ p <- use (gBoardState . bsPosition)+ let new_p = movePlayer' input p+ gBoardState . bsPosition .= new_p+ Fixed -> do+ p <- use (gBoardState . bsPosition)+ p' <- use (gBoardState . bsAx p . bsPosition)+ let new_p = movePlayer' input p'+ gBoardState . bsAx p . bsPosition .= new_p+ where+ movePlayer' KUp (Position T h) = Position T h+ movePlayer' KUp (Position v h) = Position (pred v) h++ movePlayer' KRight (Position v R) = Position v R+ movePlayer' KRight (Position v h) = Position v (succ h)++ movePlayer' KDown (Position B h) = Position B h+ movePlayer' KDown (Position v h) = Position (succ v) h++ movePlayer' KLeft (Position v L) = Position v L+ movePlayer' KLeft (Position v h) = Position v (pred h)+++calcWinners :: Array Position a -> Position -> Player+ -> (a -> Bool) -> (a -> Bool)+ -> Maybe Winner+calcWinners cells played_p pl mark_f has_f =+ let Position v h = played_p+ draw = checkDraw+ w_v = checkVertical v+ w_h = checkHorizontal h+ w_d = if isDiagonal played_p+ then checkDiagonal+ else False+ in+ if or [w_h, w_v, w_d]+ then Just (Player pl)+ else if draw+ then Just Draw+ else Nothing+ where+ check cond = all (\p -> cond (cells ^. ax p))+ checkDiagonal =+ let directions = [ [ Position T L+ , Position M C+ , Position B R ]+ , [ Position T R+ , Position M C+ , Position B L ] ]+ in any (check mark_f) directions+ checkVertical v = check mark_f [ Position v x | x <- [L .. R] ]+ checkHorizontal h = check mark_f [ Position y h | y <- [T .. B] ]+ checkDraw = check has_f $ range (Position T L, Position B R)+++getColors :: Game Colors+getColors = do+ r <- lift $ newColorID ColorRed ColorDefault 1+ b <- lift $ newColorID ColorBlue ColorDefault 2+ y <- lift $ newColorID ColorYellow ColorDefault 3+ g <- lift $ newColorID ColorGreen ColorDefault 4+ return $ \case+ Red -> r+ Blue -> b+ Yellow -> y+ Green -> g
+ src/OtherScreens.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE LambdaCase #-}+module OtherScreens where++import Control.Monad.Trans+import UI.NCurses++import Types+import Util+++-- | Select screen types+data Choice = CPlayer Player+ | CRandom+ deriving Show+++whoPlaysLoop :: Window -> Colors -> Choice -> Game (Maybe Choice)+whoPlaysLoop w colors who = do+ lift . updateWindow w $ do+ moveCursor 10 4+ drawString "Who should play?"++ uncurry moveCursor . getPos $ CPlayer X+ setColor . colors . color $ X+ drawString "X"++ uncurry moveCursor . getPos $ CPlayer O+ setColor . colors . color $ O+ drawString "O"++ uncurry moveCursor . getPos $ CRandom+ setColor . colors . color $ Draw+ drawString "Random"++ setColor defaultColorID++ uncurry moveCursor $ getPos who++ lift render++ parseInput w >>= \case+ Movement KLeft -> whoPlaysLoop w colors $ toLeft who+ Movement KRight -> whoPlaysLoop w colors $ toRight who+ Select -> return $ Just who+ Quit -> return Nothing+ _ -> whoPlaysLoop w colors who+ where+ toLeft (CPlayer X) = CPlayer X+ toLeft (CPlayer O) = CPlayer X+ toLeft CRandom = CPlayer O++ toRight (CPlayer X) = CPlayer O+ toRight (CPlayer O) = CRandom+ toRight CRandom = CRandom++ getPos (CPlayer X) = (12, 6)+ getPos (CPlayer O) = (12, 8)+ getPos CRandom = (12, 10)+++endGameLoop :: Winner -> Window -> Colors -> Game ()+endGameLoop winner w colors = do+ lift . updateWindow w $ do++ moveCursor 0 2+ setColor . colors . color $ winner+ drawString $ case winner of+ Player pl -> show pl ++ " wins!"+ Draw -> "Draw lolz..."++ lift render++ parseInput w >>= \case+ Quit -> return ()+ _ -> endGameLoop winner w colors
+ src/Types.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+module Types where++import Control.Monad.State.Strict+import Data.Array+import Lens.Simple+import UI.NCurses+++-- | Main monad+type Game a = StateT GameState Curses a+++-- | Global state+data GameState = GameState+ { _gPlayer :: Player+ , _gBoardState :: BoardState (BoardState (Maybe Player))+ , _gMode :: Mode+ , _gQuit :: Bool+ } deriving Show++data Mode = Free | Fixed deriving Show++-- | State for a 3x3 board with an inner type for each cell+data BoardState t = BoardState+ { _bsCells :: Array Position t+ , _bsPosition :: Position+ , _bsWinner :: Maybe Winner+ } deriving Show+++-- | Player and Winners+data Player = X+ | O+ deriving (Show, Eq, Ord)++data Winner = Player Player+ | Draw+ deriving (Show, Eq, Ord)+++-- | Movement and Input simplified from NCurses+data Movement = KUp | KRight | KDown | KLeft+ deriving Show++data Input = Movement Movement+ | Select | Quit+ deriving Show+++-- | Position types+data Position = Position Vertical Horizontal+ deriving (Show, Eq, Ord, Ix)++data Vertical = T | M | B deriving (Show, Enum, Eq, Ord, Ix)++data Horizontal = L | C | R deriving (Show, Enum, Eq, Ord, Ix)+++-- | Color abstraction+type Colors = GameColor -> ColorID++data GameColor = Red | Blue | Yellow | Green++class Colorable a where+ color :: a -> GameColor++instance Colorable Player where+ color X = Red+ color O = Blue++instance Colorable Winner where+ color (Player pl) = color pl+ color Draw = Yellow++instance Colorable Mode where+ color Fixed = Yellow+ color Free = Green++$(makeLenses ''GameState)+$(makeLenses ''BoardState)
+ src/Util.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE RankNTypes #-}+module Util where++import Control.Monad.Trans+import Data.Array+import Lens.Simple+import UI.NCurses++import Types+++defaultBoard :: a -> BoardState a+defaultBoard a = BoardState+ { _bsCells=listArray (Position T L, Position B R) (repeat a)+ , _bsPosition=Position M C+ , _bsWinner=Nothing }+++-- | Lens into an array+ax :: Ix i => i -> Lens (Array i a) (Array i a) a a+ax i = lens getter setter+ where+ getter = (! i)+ setter = (\arr v -> arr // [(i, v)])+++bsAx :: Position -> Lens (BoardState t) (BoardState t) t t+bsAx p = bsCells . ax p+++plusTuple :: (Num a, Num b) => (a, b) -> (a, b) -> (a, b)+plusTuple (a, b) (a', b') = (a + a', b + b')+++isDiagonal :: Position -> Bool+isDiagonal (Position T L) = True+isDiagonal (Position T R) = True+isDiagonal (Position B L) = True+isDiagonal (Position B R) = True+isDiagonal (Position M C) = True+isDiagonal _ = False+++positionToCoordinates :: Position -> Position -> (Integer, Integer)+positionToCoordinates outer_p inner_p =+ (getPos 8 outer_p) `plusTuple`+ (1, 1) `plusTuple`+ (getPos 2 inner_p)+ where+ getPos _ (Position T L) = (0, 0)+ getPos n (Position T C) = (0, n)+ getPos n (Position T R) = (0, n + n)+ getPos n (Position M L) = (n, 0)+ getPos n (Position M C) = (n, n)+ getPos n (Position M R) = (n, n + n)+ getPos n (Position B L) = (n + n, 0)+ getPos n (Position B C) = (n + n, n)+ getPos n (Position B R) = (n + n, n + n)+++parseInput :: Window -> Game Input+parseInput w = do+ ev <- lift $ getEvent w Nothing+ case ev of+ Just (EventCharacter 'q') -> return Quit+ Just (EventCharacter 'Q') -> return Quit+ Just (EventCharacter ' ') -> return Select+ Just (EventSpecialKey k) ->+ case k of+ KeyUpArrow -> return $ Movement KUp+ KeyRightArrow -> return $ Movement KRight+ KeyDownArrow -> return $ Movement KDown+ KeyLeftArrow -> return $ Movement KLeft+ _ -> parseInput w+ _ -> parseInput w
+ tateti-tateti.cabal view
@@ -0,0 +1,33 @@+name: tateti-tateti+version: 0.1.0.0+cabal-version: >=1.10+build-type: Simple+license: BSD3+license-file: LICENSE+copyright: 2015 Ezequiel A. Alvarez+maintainer: welcometothechango@mgail.com+homepage: http://github.com/alvare/tateti-tateti#readme+synopsis: Meta tic-tac-toe ncurses game.+description:+ Please see README.md+category: Game+author: Ezequiel A. Alvarez++executable tateti-tateti+ main-is: Main.hs+ build-depends:+ base >=4.7 && <5,+ ncurses >=0.2.14 && <0.3,+ mtl >=2.2.1 && <2.3,+ lens-simple >=0.1.0.8 && <0.2,+ array >=0.5.1.0 && <0.6,+ random ==1.1.*+ default-language: Haskell2010+ hs-source-dirs: src+ other-modules:+ Draw+ OtherScreens+ Types+ Util+ ghc-options: -Wall -O2+