packages feed

t3-game (empty) → 0.1.0

raw patch · 9 files changed

+305/−0 lines, 9 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, containers, hspec, mtl, safe, t3-game, text, vector

Files

+ LICENSE view
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/T3/Game.hs view
@@ -0,0 +1,27 @@+module T3.Game+  ( module T3.Game.Core+  , module T3.Game.Class+  , module T3.Game.Types+  , run+  ) where++import Prelude+import T3.Game.Core+import T3.Game.Class+import T3.Game.Types++run :: Game m => Board -> m ()+run b = play b X O ++play :: Game m => Board -> XO -> XO -> m ()+play b p0 p1 = do+  loc <- move p0+  if not (valid loc b)+    then forfeit (Win p1) (Lose p0)+    else do+      let b' = insertXO loc p0 b+      step b' p0 loc+      case result b' of+        Unfinished -> play b' p1 p0+        Winner _ -> end (Win p0) (Lose p1)+        Tie -> tie
+ src/T3/Game/Class.hs view
@@ -0,0 +1,12 @@+module T3.Game.Class where++import Prelude+import T3.Game.Types+import T3.Game.Core++class Monad m => Game m where+  move :: XO -> m Loc+  forfeit :: Win XO -> Lose XO -> m ()+  end :: Win XO -> Lose XO -> m ()+  tie :: m ()+  step :: Board -> XO -> Loc -> m ()
+ src/T3/Game/Core.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverlappingInstances #-}++module T3.Game.Core+  ( XO(..)+  , Loc(..)+  , Action(..)+  , Result(..)+  , Board+  , yinYang+  , emptyBoard+  , boardMap+  , boardList+  , boardSize+  , insertXO+  , inside+  , valid+  , result+  , dropPrefixP+  , dropPrefixJ+  ) where++import qualified Data.Map as M+import qualified Data.Text as T++import GHC.Generics+import Control.Monad (mzero)+import Data.Aeson hiding (Result)+import Data.Aeson.Types hiding (Result)+import Data.Char (toLower)+import Data.Maybe++data XO+  = X+  | O+  deriving (Show, Eq, Generic, ToJSON)++data Loc = Loc+  { locX :: Int+  , locY :: Int+  } deriving (Show, Read, Eq, Ord, Generic)++data Action = Action+  { actXO :: XO+  , actLoc :: Loc+  } deriving (Show, Eq, Generic)++data Board = Board+  { bCells :: M.Map Loc XO+  , bSize :: Int+  } deriving (Show, Eq)++data Result+  = Unfinished+  | Tie+  | Winner XO+  deriving (Show, Eq)++yinYang :: XO -> XO+yinYang X = O+yinYang O = X++emptyBoard :: Board+emptyBoard = Board M.empty 3++boardMap :: Board -> M.Map Loc XO+boardMap = bCells++boardList :: Board -> [Maybe XO]+boardList b = [M.lookup (Loc x y) (bCells b) | y <- q, x <- q]+  where q = indices b++boardSize :: Board -> Int+boardSize = bSize++inside :: Loc -> Board -> Bool+inside loc b = x >= 0 && x < bSize b && y >= 0 && y < bSize b+  where+    x = locX loc+    y = locY loc++valid :: Loc -> Board -> Bool+valid loc b = inside loc b && not (M.member loc (bCells b))++insertXO :: Loc -> XO -> Board -> Board+insertXO loc xo b =+  if inside loc b+  then b { bCells = M.insert loc xo (bCells b) }+  else b++result :: Board -> Result+result b+  | isWinner X b = Winner X+  | isWinner O b = Winner O+  | M.size (bCells b) == (bSize b) ^ (2 :: Int) = Tie+  | otherwise = Unfinished++isWinner :: XO -> Board -> Bool+isWinner xo b =+  or [all has [Loc x y | y <- q] | x <- q] ||+  or [all has [Loc x y | x <- q] | y <- q] ||+  all has [Loc z z | z <- q] ||+  all has [Loc z (bSize b - 1 - z) | z <- q]+  where+    has loc = M.lookup loc (bCells b) == Just xo+    q = indices b++indices :: Board -> [Int]+indices b = [0..bSize b - 1]++instance FromJSON Loc where+  parseJSON (Object o) = Loc <$> o .: "x" <*> o .: "y"+  parseJSON _ = mzero++instance FromJSON XO where+  parseJSON (String xo)+    | xo' == "x" = pure X+    | xo' == "o" = pure O+    | otherwise = mzero+    where+      xo' = T.map toLower xo+  parseJSON _ = mzero++instance FromJSON (Maybe XO) where+  parseJSON o@(String s) = if s == " " then pure Nothing  else fmap Just (parseJSON o)+  parseJSON _ = mzero++instance FromJSON Board where+  parseJSON b = Board <$> (M.fromList <$> board b) <*> pure size+    where+      size = 3+      board o = do+        cells :: [[Maybe XO]] <- parseJSON o+        let correctRowSize = length cells == size+        let correctColSize = and $ map ((== size) . length) cells+        let pairs = [ (Loc x y, fromJust cell) | y <- [0..pred size], x <- [0..pred size], let cell = cells !! y !! x, isJust cell ]+        if correctRowSize && correctColSize then return pairs else mzero++instance ToJSON Board where+  toJSON b = toJSON [[cvt $ M.lookup (Loc x y) m | x <- [0..pred s]] | y <- [0..pred s]]+    where+      m = boardMap b+      s = boardSize b+      cvt :: Maybe XO -> Value+      cvt = maybe (String " ") toJSON++instance ToJSON Loc where+  toJSON = dropPrefixJ "loc"++instance ToJSON Action where+  toJSON = dropPrefixJ "act"++instance FromJSON Action where+  parseJSON = dropPrefixP "act"++-- dropPrefixP :: (Generic a, GFromJSON (Rep a)) => String -> Value -> Parser a+dropPrefixP prefix = genericParseJSON defaultOptions { fieldLabelModifier = dropPrefix prefix }++-- dropPrefixJ :: (Generic a, GToJSON (Rep a)) => String -> a -> Value+dropPrefixJ prefix = genericToJSON defaultOptions { fieldLabelModifier = dropPrefix prefix }++dropPrefix :: String -> String -> String+dropPrefix prefix = (\(c:cs) -> toLower c : cs) . drop (length prefix)
+ src/T3/Game/Instance.hs view
@@ -0,0 +1,40 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module T3.Game.Instance where++import Prelude+import Control.Monad.Trans+import Safe+import T3.Game++-- Try it in the REPL++newtype Terminal a = Terminal { unTerminal :: IO a }+    deriving (Functor, Applicative, Monad, MonadIO)++instance Game Terminal where+  move xo = do+    liftIO $ putStrLn $ "Turn: " ++ show xo+    str <- liftIO $ getLine+    case readMay str of+      Nothing -> do+        liftIO $ putStrLn "Try again."+        move xo+      Just (x,y) ->+        return $ Loc x y+  forfeit (Win w) (Lose l) = do+    liftIO $ putStrLn $ show l ++ " forfeited."+    liftIO $ putStrLn $ show w ++ " won."+  end (Win w) (Lose l) = do+    liftIO $ putStrLn $ show w ++ " won, and " ++ show l ++ " lost."+  tie = liftIO $ putStrLn "Tie game!"+  step b p loc = liftIO $ do+    let d = boardList b+    let cell :: Maybe XO -> String+        cell mcell = maybe " " show mcell+    putStrLn $ show p ++ " moved to " ++ show loc+    putStrLn $ cell (d !! 0) ++ "|" ++  cell (d !! 1) ++ "|" ++ cell (d !! 2)+    putStrLn "-+-+-"+    putStrLn $ cell (d !! 3) ++ "|" ++  cell (d !! 4) ++ "|" ++ cell (d !! 5)+    putStrLn "-+-+-"+    putStrLn $ cell (d !! 6) ++ "|" ++  cell (d !! 7) ++ "|" ++ cell (d !! 8)
+ src/T3/Game/Types.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE DeriveFunctor #-}+module T3.Game.Types+  ( Win(..)+  , Lose(..)+  ) where++import Prelude++newtype Win a = Win a+  deriving (Functor, Show)++newtype Lose a = Lose a+  deriving (Functor, Show)
+ t3-game.cabal view
@@ -0,0 +1,42 @@+name:                t3-game+version:             0.1.0+synopsis:            tic-tac-toe core+description:         Please see README.md+homepage:            http://github.com/jxv/t3#readme+license: BSD3+license-file:        LICENSE+author:              Joe Vargas+maintainer:          http://github.com/jxv+copyright:           2016 Joe Vargas+category:            Game+build-type:          Simple+-- extra-source-files:+cabal-version:       >=1.10++library+  hs-source-dirs:+    src+  exposed-modules:+    T3.Game+    T3.Game.Types+    T3.Game.Class+    T3.Game.Core+    T3.Game.Instance+  build-depends:       base >= 4.7 && < 5, aeson, text, bytestring, mtl, containers, safe, vector+  default-language:    Haskell2010++test-suite t3-game-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  build-depends:+      base+    , t3-game+    , hspec+    , aeson+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/jxv/t3
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}