halma-telegram-bot (empty) → 0.1.0.0
raw patch · 17 files changed
+1927/−0 lines, 17 filesdep +aesondep +aeson-prettydep +basesetup-changed
Dependencies added: aeson, aeson-pretty, base, bytestring, containers, data-default, diagrams-cairo, diagrams-lib, directory, exceptions, filepath, halma, http-client, http-client-tls, megaparsec, mtl, optparse-applicative, semigroups, servant-client, telegram-api, temporary, text, transformers, vector
Files
- LICENSE +20/−0
- Setup.hs +2/−0
- halma-telegram-bot.cabal +62/−0
- src/Game/Halma/TelegramBot/CmdLineOptions.hs +51/−0
- src/Game/Halma/TelegramBot/Controller.hs +485/−0
- src/Game/Halma/TelegramBot/Controller/BotM.hs +72/−0
- src/Game/Halma/TelegramBot/Controller/Helpers.hs +66/−0
- src/Game/Halma/TelegramBot/Controller/SlashCmd.hs +27/−0
- src/Game/Halma/TelegramBot/Controller/Types.hs +23/−0
- src/Game/Halma/TelegramBot/Model.hs +160/−0
- src/Game/Halma/TelegramBot/Model/MoveCmd.hs +247/−0
- src/Game/Halma/TelegramBot/Model/Types.hs +293/−0
- src/Game/Halma/TelegramBot/View.hs +12/−0
- src/Game/Halma/TelegramBot/View/DrawBoard.hs +98/−0
- src/Game/Halma/TelegramBot/View/I18n.hs +226/−0
- src/Game/Halma/TelegramBot/View/Pretty.hs +52/−0
- src/Main.hs +31/−0
+ LICENSE view
@@ -0,0 +1,20 @@+The MIT License (MIT)+Copyright © 2016 Tim Baumann, http://timbaumann.info++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the “Software”), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ halma-telegram-bot.cabal view
@@ -0,0 +1,62 @@+name: halma-telegram-bot+version: 0.1.0.0+synopsis: Telegram bot for playing Halma+description: Play Halma (aka Chinese Checkers) in Telegram against your friends or an AI+homepage: https://github.com/timjb/halma+license: MIT+license-file: LICENSE+author: Tim Baumann+maintainer: tim@timbaumann.info+copyright: 2016-2017 Tim Baumann+category: Game+build-type: Simple+cabal-version: >= 1.22++source-repository head+ type: git+ location: https://github.com/timjb/halma.git++Executable halma-telegram-bot+ Ghc-options: -threaded -Wall+ default-language: Haskell2010+ Hs-source-dirs: src+ main-is: Main.hs+ other-modules:+ Game.Halma.TelegramBot.CmdLineOptions+ Game.Halma.TelegramBot.Controller+ Game.Halma.TelegramBot.Controller.BotM+ Game.Halma.TelegramBot.Controller.Helpers+ Game.Halma.TelegramBot.Controller.SlashCmd+ Game.Halma.TelegramBot.Controller.Types+ Game.Halma.TelegramBot.Model+ Game.Halma.TelegramBot.Model.MoveCmd+ Game.Halma.TelegramBot.Model.Types+ Game.Halma.TelegramBot.View+ Game.Halma.TelegramBot.View.DrawBoard+ Game.Halma.TelegramBot.View.I18n+ Game.Halma.TelegramBot.View.Pretty+ build-depends:+ halma >= 0.3.0.0 && < 0.4,+ base >= 4.6 && < 5,+ telegram-api >= 0.6.1.0 && < 0.7,+ text,+ transformers,+ servant-client,+ http-client,+ http-client-tls,+ data-default,+ megaparsec,+ mtl,+ exceptions,+ temporary,+ diagrams-lib,+ diagrams-cairo,+ directory,+ semigroups,+ containers,+ aeson,+ aeson-pretty,+ optparse-applicative,+ filepath,+ bytestring,+ vector
+ src/Game/Halma/TelegramBot/CmdLineOptions.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE OverloadedStrings #-}++module Game.Halma.TelegramBot.CmdLineOptions+ ( BotOptions (..)+ , optionsParserInfo+ ) where++import Data.Monoid ((<>))+import qualified Data.Text as T+import qualified Options.Applicative as OA+import qualified Web.Telegram.API.Bot as TG++data BotOptions+ = BotOptions+ { boToken :: TG.Token+ , boOutputDirectory :: Maybe FilePath+ } deriving (Show, Eq)++optionsParserInfo :: OA.ParserInfo BotOptions+optionsParserInfo =+ OA.info (OA.helper <*> optionsParser) $ mconcat+ [ OA.header "halma-telegram-bot -- Play Chinese Checkers in Telegram Chats"+ , OA.progDesc "This is the server for the Telegram HalmaBot (https://github.com/timjb/halma)"+ ]++optionsParser :: OA.Parser BotOptions+optionsParser =+ BotOptions+ <$> tokenP+ <*> saveDirectoryP+ where+ tokenP =+ fmap (TG.Token . ("bot" `ensureIsPrefixOf`) . T.pack) $+ OA.strArgument $ mconcat+ [ OA.metavar "TELEGRAM_TOKEN"+ ]+ saveDirectoryP =+ OA.optional $ OA.strOption $ mconcat+ [ OA.long "output"+ , OA.short 'o'+ , OA.metavar "OUTPUT_DIR"+ , OA.help "Where to save chat data"+ ]++ensureIsPrefixOf :: T.Text -> T.Text -> T.Text+ensureIsPrefixOf prefix str =+ if prefix `T.isPrefixOf` str then+ str+ else+ prefix <> str+
+ src/Game/Halma/TelegramBot/Controller.hs view
@@ -0,0 +1,485 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}++module Game.Halma.TelegramBot.Controller+ ( halmaBot+ ) where++import Game.Halma.Board+import Game.Halma.Configuration+import Game.Halma.TelegramBot.Controller.BotM+import Game.Halma.TelegramBot.Controller.Helpers+import Game.Halma.TelegramBot.Controller.SlashCmd+import Game.Halma.TelegramBot.Controller.Types+import Game.Halma.TelegramBot.Model+import Game.Halma.TelegramBot.View+import Game.TurnCounter+import qualified Game.Halma.AI.Ignorant as IgnorantAI+import qualified Game.Halma.AI.Competitive as CompetitiveAI++import Control.Concurrent (threadDelay)+import Data.Foldable (toList)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Monoid ((<>))+import Control.Monad (unless)+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Reader.Class (ask)+import Control.Monad.State.Class (MonadState (..), gets, modify)+import Servant.Common.Req (ServantError)+import System.Directory (doesFileExist, getTemporaryDirectory, renameFile)+import System.FilePath ((</>))+import System.IO (hClose)+import System.IO.Temp (openTempFile)+import qualified Data.Aeson as A+import qualified Data.Aeson.Encode.Pretty as A+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Map as M+import qualified Data.Text as T+import qualified Web.Telegram.API.Bot as TG++getUpdates :: GlobalBotM (Either ServantError [TG.Update])+getUpdates = do+ nid <- gets bsNextId+ let+ limit = 100+ timeout = 10+ updateReq token =+ TG.getUpdates token (Just nid) (Just limit) (Just timeout)+ runReq updateReq >>= \case+ Left err -> return (Left err)+ Right (TG.Response updates _resParams) -> do+ unless (null updates) $ do+ let nid' = 1 + maximum (map TG.update_id updates)+ modify (\s -> s { bsNextId = nid' })+ return (Right updates)++getUpdatesRetry :: GlobalBotM [TG.Update]+getUpdatesRetry =+ getUpdates >>= \case+ Left err -> do+ printError err+ liftIO $ threadDelay 1000000 -- wait one second+ getUpdatesRetry+ Right updates -> pure updates++sendCurrentBoard :: HalmaState -> BotM ()+sendCurrentBoard halmaState =+ withRenderedBoardInPngFile halmaState mempty $ \path -> do+ chatId <- gets hcId+ let+ fileUpload = TG.localFileUpload path+ photoReq = TG.uploadPhotoRequest (TG.ChatId chatId) fileUpload+ logErrors $ runReq $ \token -> TG.uploadPhoto token photoReq++handleCommand :: CmdCall -> BotM (Maybe (BotM ()))+handleCommand cmdCall =+ case cmdCall of+ CmdCall { cmdCallName = "help" } -> do+ sendI18nMsg hlHelpMsg+ pure Nothing+ CmdCall { cmdCallName = "start" } ->+ pure $ Just $ do+ modify $ \chat ->+ chat { hcMatchState = NoMatch }+ sendI18nMsg hlWelcomeMsg+ CmdCall { cmdCallName = "setlang", cmdCallArgs = Nothing } -> do+ sendMsg $ textMsg $+ "/setlang expects an argument!"+ pure Nothing+ CmdCall { cmdCallName = "setlang", cmdCallArgs = Just arg } ->+ case parsePrettyLocaleId arg of+ Just localeId ->+ pure $ Just $+ modify $ \chat -> chat { hcLocale = localeId }+ Nothing -> do+ sendMsg $ textMsg $+ "Could not parse language. Must be one of the following strings: " <>+ T.intercalate ", " (map prettyLocaleId allLocaleIds)+ pure Nothing+ CmdCall { cmdCallName = "newmatch" } ->+ pure $ Just $ modify $ \chat ->+ chat { hcMatchState = GatheringPlayers NoPlayers }+ CmdCall { cmdCallName = "newround" } -> do+ matchState <- gets hcMatchState+ case matchState of+ MatchRunning match ->+ pure $ Just $ do+ sendI18nMsg hlStartingANewRound+ modify $ \chat ->+ chat { hcMatchState = MatchRunning (newRound match) }+ _ -> do+ sendI18nMsg hlCantStartNewRoundBecauseNoMatch+ pure Nothing+ CmdCall { cmdCallName = "undo" } -> do+ matchState <- gets hcMatchState+ case matchState of+ MatchRunning match@Match{ matchCurrentGame = Just game } ->+ case undoLastMove game of+ Just game' ->+ let+ match' = match { matchCurrentGame = Just game' }+ in+ pure $ Just $+ modify $ \chat ->+ chat { hcMatchState = MatchRunning match' }+ Nothing -> do+ sendI18nMsg (flip hlCantUndo Nothing)+ pure Nothing+ _ -> do+ sendI18nMsg (flip hlCantUndo (Just CantUndoNoGame))+ pure Nothing+ _ -> pure Nothing++sendMoveSuggestions+ :: TG.User+ -> TG.Message+ -> HalmaState+ -> NonEmpty (MoveCmd, Move)+ -> BotM ()+sendMoveSuggestions sender msg game suggestions = do+ let+ text =+ prettyUser sender <> ", the move command you sent is ambiguous. " <>+ "Please send another move command or choose one in the " <>+ "following list."+ suggestionToButton (moveCmd, _move) =+ showMoveCmd moveCmd+ keyboard =+ (mkKeyboard [suggestionToButton <$> toList suggestions])+ { TG.reply_selective = Just True+ }+ suggestionToLabel (moveCmd, move) =+ ( moveTo move+ , maybe "" showTargetModifier (moveTargetModifier moveCmd)+ )+ boardLabels =+ M.fromList $ map suggestionToLabel $ toList suggestions+ withRenderedBoardInPngFile game boardLabels $ \path -> do+ chatId <- gets hcId+ let+ fileUpload = TG.localFileUpload path+ photoReq =+ (TG.uploadPhotoRequest (TG.ChatId chatId) fileUpload)+ { TG.photo_caption = Just text+ , TG.photo_reply_to_message_id = Just (TG.message_id msg)+ , TG.photo_reply_markup = Just keyboard+ }+ logErrors $ runReq $ \token -> TG.uploadPhoto token photoReq++announceResult+ :: ExtendedPartyResult+ -> BotM ()+announceResult extendedResult =+ sendI18nMsg $ \locale -> hlCongratulation locale extendedResult++handleMoveCmd+ :: Match+ -> HalmaState+ -> MoveCmd+ -> TG.Message+ -> BotM (Maybe (BotM ()))+handleMoveCmd match game moveCmd fullMsg = do+ liftIO $ putStrLn $ T.unpack $ showMoveCmd moveCmd+ case TG.from fullMsg of+ Nothing -> do+ sendMsg $ textMsg $+ "can't identify sender of move command " <> showMoveCmd moveCmd <> "!"+ pure Nothing+ Just sender -> do+ let+ currParty = currentPlayer (hsTurnCounter game)+ homeCorner = partyHomeCorner currParty+ player = partyPlayer currParty+ checkResult =+ checkMoveCmd (matchRules match) (hsBoard game) homeCorner moveCmd+ case checkResult of+ _ | player /= TelegramPlayer sender -> do+ let notYourTurnInfo =+ NotYourTurnInfo+ { you = sender+ , thePlayerWhoseTurnItIs = player+ }+ sendI18nMsg (flip hlNotYourTurn notYourTurnInfo)+ pure Nothing+ MoveImpossible reason -> do+ sendMsg $ textMsg $+ "This move is not possible: " <> T.pack reason+ pure Nothing+ MoveSuggestions suggestions -> do+ sendMoveSuggestions sender fullMsg game suggestions+ pure Nothing+ MoveFoundUnique move ->+ case doMove move game of+ Left err -> do+ printError err+ pure Nothing+ Right afterMove -> do+ handleAfterMove match game afterMove++handleAfterMove+ :: Match+ -> HalmaState+ -> AfterMove+ -> BotM (Maybe (BotM ()))+handleAfterMove match game afterMove =+ case afterMove of+ GameEnded lastResult -> do+ announceResult lastResult+ let+ gameResult =+ GameResult+ { grNumberOfMoves = hsFinished game ++ [eprPartyResult lastResult]+ }+ match' =+ match+ { matchCurrentGame = Nothing+ , matchHistory = matchHistory match ++ [gameResult]+ }+ pure $ Just $+ modify $ \chat ->+ chat { hcMatchState = MatchRunning match' }+ -- TODO: offer to start new game+ GameContinues mPartyResult game' -> do+ mapM_ announceResult mPartyResult+ let+ match' = match { matchCurrentGame = Just game' }+ pure $ Just $+ modify $ \chat ->+ chat { hcMatchState = MatchRunning match' }++handleTextMsg+ :: T.Text+ -> TG.Message+ -> BotM (Maybe (BotM ()))+handleTextMsg text fullMsg = do+ matchState <- gets hcMatchState+ case (matchState, text) of+ (_, parseCmdCall -> Just cmdCall) ->+ handleCommand cmdCall+ ( MatchRunning match@Match { matchCurrentGame = Just game }, parseMoveCmd -> Right moveCmd) ->+ handleMoveCmd match game moveCmd fullMsg+ (GatheringPlayers players, "me") ->+ pure $ Just (addTelegramPlayer players)+ (GatheringPlayers players, "yes, me") ->+ pure $ Just (addTelegramPlayer players)+ (GatheringPlayers players, "an AI") ->+ pure $ Just (addAIPlayer players)+ (GatheringPlayers players, "yes, an AI") ->+ pure $ Just (addAIPlayer players)+ (GatheringPlayers (EnoughPlayers config), "no") ->+ pure $ Just (startMatch config)+ _ -> pure Nothing+ where+ addPlayer :: Player -> PlayersSoFar Player -> BotM ()+ addPlayer new playersSoFar = do+ playersSoFar' <-+ case playersSoFar of+ NoPlayers ->+ pure $ OnePlayer new+ OnePlayer a ->+ case configuration SmallGrid (TwoPlayers a new) of+ Just config -> pure $ EnoughPlayers config+ Nothing -> fail "could not create configuration with two players and small grid!"+ EnoughPlayers config ->+ pure $ EnoughPlayers (addPlayerToConfig new config)+ chat <- get+ case playersSoFar' of+ EnoughPlayers config@(configurationPlayers -> SixPlayers{}) ->+ put $ chat { hcMatchState = MatchRunning (newMatch config) }+ _ ->+ put $ chat { hcMatchState = GatheringPlayers playersSoFar' }+ addAIPlayer :: PlayersSoFar Player -> BotM ()+ addAIPlayer = addPlayer AIPlayer+ addTelegramPlayer :: PlayersSoFar Player -> BotM ()+ addTelegramPlayer players =+ case TG.from fullMsg of+ Nothing ->+ sendMsg $ textMsg "cannot add sender of last message as a player!"+ Just user ->+ addPlayer (TelegramPlayer user) players+ startMatch players =+ modify $ \chat ->+ chat { hcMatchState = MatchRunning (newMatch players) }++sendGatheringPlayers :: PlayersSoFar Player -> BotM ()+sendGatheringPlayers playersSoFar =+ case playersSoFar of+ NoPlayers ->+ sendMsg $ textMsgWithKeyboard+ "Starting a new match! Who is the first player?"+ meKeyboard+ OnePlayer firstPlayer ->+ let+ text =+ "The first player is " <> prettyPlayer firstPlayer <> ".\n" <>+ "Who is the second player?"+ in+ sendMsg (textMsgWithKeyboard text meKeyboard)+ EnoughPlayers config -> do+ (count, nextOrdinal) <-+ case configurationPlayers config of+ TwoPlayers {} -> pure ("two", "third")+ ThreePlayers {} -> pure ("three", "fourth")+ FourPlayers {} -> pure ("four", "fifth")+ FivePlayers {} -> pure ("five", "sixth")+ SixPlayers {} ->+ fail "unexpected state: gathering players although there are already six!"+ let+ text =+ "The first " <> count <> " players are " <>+ prettyList (map prettyPlayer (toList (configurationPlayers config))) <> ".\n" <>+ "Is there a " <> nextOrdinal <> " player?"+ sendMsg (textMsgWithKeyboard text anotherPlayerKeyboard)+ where+ prettyList :: [T.Text] -> T.Text+ prettyList xs =+ case xs of+ [] -> "<empty list>"+ [x] -> x+ _ -> T.intercalate ", " (init xs) <> " and " <> last xs+ meKeyboard = mkKeyboard [["me"], ["an AI"]]+ anotherPlayerKeyboard =+ mkKeyboard [["yes, me"], ["yes, an AI"], ["no"]]++doAIMove :: Match -> HalmaState -> BotM ()+doAIMove match game = do+ let+ tc = hsTurnCounter game+ board = hsBoard game+ rules = matchRules match+ numberOfPlayers = length $ tcPlayers tc+ currParty = currentPlayer tc+ aiMove =+ if numberOfPlayers == 2 then+ let+ nextParty = nextPlayer tc+ perspective = (partyHomeCorner currParty, partyHomeCorner nextParty)+ in+ CompetitiveAI.aiMove rules board perspective+ else+ IgnorantAI.aiMove rules board (partyHomeCorner currParty)+ mAIMoveCmd = moveToMoveCmd rules board aiMove+ case doMove aiMove game of+ Left err ->+ fail $ "doing an AI move failed unexpectedly: " ++ err+ Right afterMove -> do+ case mAIMoveCmd of+ Just moveCmd ->+ let aiMove =+ AIMove+ { aiHomeCorner = partyHomeCorner currParty+ , aiMoveCmd = moveCmd+ }+ in sendI18nMsg (flip hlAIMove aiMove)+ Nothing -> pure ()+ handleAfterMove match game afterMove >>= sequence_++sendGameState :: Match -> HalmaState -> BotM ()+sendGameState match game = do+ sendCurrentBoard game+ let+ currParty = currentPlayer (hsTurnCounter game)+ case partyPlayer currParty of+ AIPlayer -> do+ doAIMove match game+ sendMatchState+ TelegramPlayer user ->+ sendI18nMsg (\hl -> hlYourTurn hl (partyHomeCorner currParty) user)++sendMatchState :: BotM ()+sendMatchState = do+ matchState <- gets hcMatchState+ case matchState of+ NoMatch ->+ sendI18nMsg hlNoMatchMsg+ GatheringPlayers players ->+ sendGatheringPlayers players+ MatchRunning match ->+ case matchCurrentGame match of+ Nothing ->+ sendI18nMsg hlNoRoundMsg+ Just game -> sendGameState match game++loadHalmaChat :: ChatId -> GlobalBotM HalmaChat+loadHalmaChat chatId = do+ botState <- get+ cfg <- ask+ case M.lookup chatId (bsChats botState) of+ Just chat -> pure chat+ Nothing -> do+ case bcOutputDirectory cfg of+ Nothing -> pure dflt+ Just outDir -> do+ let filePath = outDir </> (show chatId ++ ".json")+ fileExists <- liftIO $ doesFileExist filePath+ if not fileExists then+ pure dflt+ else do+ jsonLBS <- liftIO $ LBS.readFile filePath+ case A.eitherDecode jsonLBS of+ Left err ->+ fail $ "decoding " ++ filePath ++ " failed: " ++ err+ Right chat ->+ pure chat+ where+ dflt = initialHalmaChat chatId++saveHalmaChat :: HalmaChat -> GlobalBotM ()+saveHalmaChat chat = do+ modify $ \botState ->+ let+ chats = bsChats botState+ chats' = M.insert (hcId chat) chat chats+ in+ botState { bsChats = chats' }+ cfg <- ask+ case bcOutputDirectory cfg of+ Nothing -> pure ()+ Just outDir ->+ liftIO $ do+ let fileName = show (hcId chat) ++ ".json"+ fullFilePath = outDir </> fileName+ systemTempDir <- getTemporaryDirectory+ (tmpFilePath, tmpFileHandle) <- openTempFile systemTempDir fileName+ LBS.hPut tmpFileHandle (A.encodePretty chat)+ hClose tmpFileHandle+ renameFile tmpFilePath fullFilePath++withHalmaChat+ :: ChatId+ -> BotM a+ -> GlobalBotM a+withHalmaChat chatId action = do+ chat <- loadHalmaChat chatId+ (res, chat') <- stateZoom chat action+ saveHalmaChat chat'+ return res++handleUpdate+ :: TG.Update+ -> GlobalBotM ()+handleUpdate update = do+ liftIO $ print update+ case update of+ TG.Update { TG.message = Just msg } -> handleMsg msg+ _ -> return ()+ where+ handleMsg msg =+ case msg of+ TG.Message { TG.text = Just txt, TG.chat = tgChat } ->+ withHalmaChat (fromIntegral (TG.chat_id tgChat)) $ do+ handleTextMsg txt msg >>= \case+ Nothing -> return ()+ Just action -> do+ action+ sendMatchState+ _ -> return ()++halmaBot :: GlobalBotM ()+halmaBot = do+ updates <- getUpdatesRetry+ mapM_ handleUpdate updates+ halmaBot
+ src/Game/Halma/TelegramBot/Controller/BotM.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}++module Game.Halma.TelegramBot.Controller.BotM+ ( GeneralBotM+ , GlobalBotM+ , BotM+ , evalGlobalBotM+ , stateZoom+ , runReq+ , printError+ , logErrors+ ) where++import Game.Halma.TelegramBot.Controller.Types+import Game.Halma.TelegramBot.Model+import Game.Halma.TelegramBot.View.I18n++import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Reader.Class (MonadReader (..))+import Control.Monad.State.Class (MonadState, gets)+import Control.Monad.Trans.Reader (ReaderT(..))+import Control.Monad.Trans.State (StateT(..), evalStateT)+import Network.HTTP.Client (Manager)+import Servant.Common.Req (ServantError)+import System.IO (hPrint, stderr)+import qualified Data.Text as T+import qualified Web.Telegram.API.Bot as TG++newtype GeneralBotM s a+ = GeneralBotM+ { unGeneralBotM :: ReaderT BotConfig (StateT s IO) a+ } deriving+ ( Functor, Applicative, Monad+ , MonadIO, MonadThrow, MonadCatch, MonadMask+ , MonadState s, MonadReader BotConfig+ )++type GlobalBotM = GeneralBotM BotState+type BotM = GeneralBotM HalmaChat++initialBotState :: BotState+initialBotState =+ BotState+ { bsNextId = 0+ , bsChats = mempty+ }++evalGlobalBotM :: GlobalBotM a -> BotConfig -> IO a+evalGlobalBotM action cfg =+ evalStateT (runReaderT (unGeneralBotM action) cfg) initialBotState++stateZoom :: t -> GeneralBotM t a -> GeneralBotM s (a, t)+stateZoom initial action = do+ GeneralBotM $+ ReaderT $ \cfg ->+ liftIO $ runStateT (runReaderT (unGeneralBotM action) cfg) initial++runReq :: (TG.Token -> Manager -> IO a) -> GeneralBotM s a+runReq reqAction = do+ cfg <- ask+ liftIO $ reqAction (bcToken cfg) (bcManager cfg)++printError :: (MonadIO m, Show a) => a -> m ()+printError val = liftIO (hPrint stderr val)++logErrors :: BotM (Either ServantError a) -> BotM ()+logErrors action =+ action >>= \case+ Left err -> printError err+ Right _res -> return ()
+ src/Game/Halma/TelegramBot/Controller/Helpers.hs view
@@ -0,0 +1,66 @@+module Game.Halma.TelegramBot.Controller.Helpers+ ( translate+ , sendI18nMsg+ , mkKeyboard+ , Msg+ , sendMsg+ , textMsg+ , textMsgWithKeyboard+ ) where++import Game.Halma.TelegramBot.Controller.BotM+import Game.Halma.TelegramBot.Model+import Game.Halma.TelegramBot.View.I18n++import Control.Monad.State.Class (gets)+import qualified Web.Telegram.API.Bot as TG+import qualified Data.Text as T++translate :: (HalmaLocale -> a) -> BotM a+translate getTranslation = gets (getTranslation . localeById . hcLocale)++sendI18nMsg :: (HalmaLocale -> T.Text) -> BotM ()+sendI18nMsg getText = do+ text <- translate getText+ sendMsg $ textMsg text -- todo: url link suppression++mkButton :: T.Text -> TG.KeyboardButton+mkButton text =+ TG.KeyboardButton+ { TG.kb_text = text+ , TG.kb_request_contact = Nothing+ , TG.kb_request_location = Nothing+ }++mkKeyboard :: [[T.Text]] -> TG.ReplyKeyboard+mkKeyboard buttonLabels =+ TG.ReplyKeyboardMarkup+ { TG.reply_keyboard = fmap mkButton <$> buttonLabels+ , TG.reply_resize_keyboard = Just True+ , TG.reply_one_time_keyboard = Just True+ , TG.reply_selective = Just False+ }++type Msg = ChatId -> TG.SendMessageRequest++sendMsg :: Msg -> BotM ()+sendMsg createMsg = do+ chatId <- gets hcId+ logErrors $ runReq $ \token -> TG.sendMessage token (createMsg chatId)++textMsg :: T.Text -> Msg+textMsg text chatId =+ TG.SendMessageRequest+ { TG.message_chat_id = TG.ChatId chatId+ , TG.message_text = text+ , TG.message_parse_mode = Just TG.Markdown+ , TG.message_disable_web_page_preview = Just True+ , TG.message_disable_notification = Nothing+ , TG.message_reply_to_message_id = Nothing+ , TG.message_reply_markup = Nothing+ }++textMsgWithKeyboard :: T.Text -> TG.ReplyKeyboard -> Msg+textMsgWithKeyboard text keyboard chatId =+ (TG.sendMessageRequest (TG.ChatId chatId) text)+ { TG.message_reply_markup = Just keyboard }
+ src/Game/Halma/TelegramBot/Controller/SlashCmd.hs view
@@ -0,0 +1,27 @@+module Game.Halma.TelegramBot.Controller.SlashCmd+ ( CmdCall (..)+ , parseCmdCall+ ) where++import Control.Monad (guard)+import Data.Char (isAlphaNum, isSpace)++import qualified Data.Text as T++data CmdCall+ = CmdCall+ { cmdCallName :: T.Text+ , cmdCallArgs :: Maybe T.Text+ } deriving (Show, Eq)++parseCmdCall :: T.Text -> Maybe CmdCall+parseCmdCall str = do+ guard $ not (T.null str)+ guard $ T.head str == '/'+ let rest = T.tail str+ isCmdChar c = isAlphaNum c || c `elem` ("_-" :: String)+ (cmdName, rest') = T.span isCmdChar rest+ guard $ not (T.null cmdName)+ let rest'' = T.dropWhile isSpace rest'+ args = if T.null rest'' then Nothing else Just rest''+ pure $ CmdCall { cmdCallName = cmdName, cmdCallArgs = args }
+ src/Game/Halma/TelegramBot/Controller/Types.hs view
@@ -0,0 +1,23 @@+module Game.Halma.TelegramBot.Controller.Types+ ( BotConfig (..)+ , BotState (..)+ ) where++import Game.Halma.TelegramBot.Model.Types++import Network.HTTP.Client (Manager)+import qualified Data.Map as M+import qualified Web.Telegram.API.Bot as TG++data BotConfig+ = BotConfig+ { bcToken :: TG.Token+ , bcOutputDirectory :: Maybe FilePath+ , bcManager :: Manager+ }++data BotState+ = BotState+ { bsNextId :: Int+ , bsChats :: M.Map ChatId HalmaChat+ } deriving (Show)
+ src/Game/Halma/TelegramBot/Model.hs view
@@ -0,0 +1,160 @@+module Game.Halma.TelegramBot.Model+ ( module Game.Halma.TelegramBot.Model.MoveCmd+ , module Game.Halma.TelegramBot.Model.Types+ , AfterMove (..)+ , doMove+ , undoLastMove+ , newMatch+ , newRound+ , initialHalmaChat+ , newRound+ ) where++import Game.Halma.Board+import Game.Halma.Configuration+import Game.Halma.Rules+import Game.Halma.TelegramBot.Model.Types+import Game.Halma.TelegramBot.Model.MoveCmd+import Game.TurnCounter++import Data.Foldable (toList)+import Data.Maybe (fromMaybe)+import qualified Data.Map as M++initialHalmaChat :: ChatId -> HalmaChat+initialHalmaChat chatId =+ HalmaChat+ { hcId = chatId+ , hcLocale = En+ , hcMatchState = NoMatch+ }++initialHalmaState :: Configuration Player -> HalmaState+initialHalmaState config =+ let+ (board, turnCounter) = newGame config+ in+ HalmaState+ { hsBoard = board+ , hsTurnCounter = toParty <$> turnCounter+ , hsLastMove = Nothing+ , hsFinished = []+ }+ where+ toParty (dir, player) = Party { partyPlayer = player, partyHomeCorner = dir }++data AfterMove+ = GameContinues (Maybe ExtendedPartyResult) HalmaState -- ^ result if a player finished in the last turn+ | GameEnded ExtendedPartyResult -- ^ result of the last player to finish+ deriving (Show, Eq)++doMove+ :: Move+ -> HalmaState+ -> Either String AfterMove+ -- ^ an error or the new state and whether the party has just won+doMove move state =+ case movePiece move (hsBoard state) of+ Left err -> Left err+ Right board' ->+ let+ wasLastMove = hasFinished board' (partyHomeCorner party)+ mExtendedPartyResult =+ if wasLastMove then+ Just $ getExtendedPartyResult (hsTurnCounter state) (hsFinished state)+ else+ Nothing+ finished' =+ hsFinished state +++ toList (eprPartyResult <$> mExtendedPartyResult)+ numberOfPlayers = length $ tcPlayers $ hsTurnCounter state+ isGameEnd = length finished' == numberOfPlayers+ turnCounter' =+ fromMaybe (hsTurnCounter state) $+ nextTurnWith (`notElem` map prParty finished') $+ hsTurnCounter state+ state' =+ HalmaState+ { hsBoard = board'+ , hsTurnCounter = turnCounter'+ , hsLastMove = Just move+ , hsFinished = finished'+ }+ in+ Right $+ case mExtendedPartyResult of+ Just extendedPartyResult | isGameEnd ->+ GameEnded extendedPartyResult+ _ ->+ GameContinues mExtendedPartyResult state'+ where+ party = currentPlayer (hsTurnCounter state)+ getExtendedPartyResult turnCounter finishedBefore =+ let+ numberOfTurns = currentRound turnCounter + 1+ place =+ length $ filter ((< numberOfTurns) . prNumberOfTurns) finishedBefore+ in+ ExtendedPartyResult+ { eprPartyResult =+ PartyResult+ { prParty = party+ , prNumberOfTurns = numberOfTurns+ }+ , eprPlace = place+ , eprPlaceShared = place < length finishedBefore+ , eprLag =+ case finishedBefore of+ [] -> 0+ winner:_ -> numberOfTurns - prNumberOfTurns winner+ , eprNumberOfPlayers = length (tcPlayers turnCounter)+ }++undoLastMove :: HalmaState -> Maybe HalmaState+undoLastMove state = do+ move <- hsLastMove state+ board' <- eitherToMaybe $ movePiece (invertMove move) (hsBoard state)+ let+ finished' = + filter (hasFinished board' . partyHomeCorner . prParty) $+ hsFinished state+ Just+ HalmaState+ { hsBoard = board'+ , hsTurnCounter =+ fromMaybe (hsTurnCounter state) $+ nextTurnWith (`notElem` map prParty finished') $+ hsTurnCounter state+ , hsLastMove = Nothing+ , hsFinished = finished'+ }+ where+ eitherToMaybe = either (const Nothing) Just+ invertMove Move { moveFrom = from, moveTo = to } =+ Move { moveFrom = to, moveTo = from }++newMatch :: Configuration Player -> Match+newMatch config =+ Match+ { matchConfig = config+ , matchRules = rules+ , matchHistory = []+ , matchCurrentGame = Just (initialHalmaState config)+ }+ where+ rules =+ RuleOptions+ { movingBackwards = Temporarily+ , invading = Allowed+ }++newRound :: Match -> Match+newRound match = + match+ { matchHistory = matchHistory match ++ toList mGameResult+ , matchCurrentGame = Just game'+ }+ where+ game' = initialHalmaState (matchConfig match)+ mGameResult = GameResult . hsFinished <$> matchCurrentGame match+
+ src/Game/Halma/TelegramBot/Model/MoveCmd.hs view
@@ -0,0 +1,247 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module Game.Halma.TelegramBot.Model.MoveCmd+ ( TargetModifier+ , showTargetModifier+ , PieceNumber+ , showPieceNumber+ , RowNumber (..)+ , internalToHumanRowNumber+ , humanToInternalRowNumber+ , radiusInRows+ , MoveCmd (..)+ , showMoveCmd+ , parseMoveCmd+ , moveToMoveCmd+ , CheckMoveCmdResult (..)+ , checkMoveCmd+ ) where++import Game.Halma.Board+import Game.Halma.Rules++import Data.Bifunctor (first)+import Data.Char (chr, ord, toUpper)+import Data.List (sortBy)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Monoid ((<>))+import Data.Traversable (mapAccumL)+import Data.Tuple (swap)+import Data.Word (Word8)+import qualified Data.Map as M+import qualified Data.Text as T+import qualified Text.Megaparsec as P++data TargetModifier+ = TargetModifier+ { _unTargetModifier :: Int+ } deriving (Show, Eq, Ord)++showTargetModifier :: TargetModifier -> T.Text+showTargetModifier (TargetModifier i) =+ case i of+ -1 -> "l"+ 0 -> "c"+ 1 -> "r"+ _ | i < -1 ->+ T.replicate (-i-1) "L"+ _ -> -- i > 1+ T.replicate (i-1) "R"++targetModifierParser :: P.Parsec P.Dec T.Text TargetModifier+targetModifierParser =+ P.choice+ [ TargetModifier . negate . (+1) <$> counting 'L'+ , TargetModifier (-1) <$ P.char 'l'+ , TargetModifier 0 <$ P.char' 'c'+ , TargetModifier 1 <$ P.char 'r'+ , TargetModifier . (+1) <$> counting 'R'+ ]+ where+ counting c = length <$> P.some (P.char c)++tagWithTargetModifier :: Traversable t => t a -> t (TargetModifier, a)+tagWithTargetModifier untagged =+ snd (mapAccumL accumFun firstTargetModifier untagged)+ where+ l = length untagged+ accumFun targetModifier val =+ (nextTargetModifier targetModifier, (targetModifier, val))+ firstTargetModifier = TargetModifier (- (l `div` 2))+ nextTargetModifier (TargetModifier i) =+ if i == -1 && even l then+ TargetModifier 1+ else+ TargetModifier (i+1)++type PieceNumber = Word8++pieceNumberToChar :: PieceNumber -> Char+pieceNumberToChar i = chr (ord 'A' + fromIntegral i - 1)++pieceNumberFromChar :: Char -> Maybe PieceNumber+pieceNumberFromChar c =+ let+ j = 1 + ord (toUpper c) - ord 'A'+ in if 1 <= j && j <= 15 then+ Just (fromIntegral j)+ else+ Nothing++showPieceNumber :: PieceNumber -> T.Text+showPieceNumber = T.singleton . pieceNumberToChar++pieceNumberParser :: P.Parsec P.Dec T.Text PieceNumber+pieceNumberParser = do+ c <- P.oneOf' (pieceNumberToChar <$> [1..15]) P.<?> "piece number"+ case pieceNumberFromChar c of+ Nothing ->+ fail "unexpected error while parsing piece number"+ Just i -> pure i++-- | Human readable (non-negative) row number+newtype RowNumber+ = RowNumber+ { unRowNumber :: Int+ } deriving (Show, Eq, Ord)++radiusInRows :: HalmaGrid -> Int+radiusInRows grid =+ case grid of+ SmallGrid -> 8+ LargeGrid -> 10++humanToInternalRowNumber :: HalmaGrid -> RowNumber -> Int+humanToInternalRowNumber grid (RowNumber i) = i - radiusInRows grid++internalToHumanRowNumber :: HalmaGrid -> Int -> RowNumber+internalToHumanRowNumber grid i = RowNumber (i + radiusInRows grid)++data MoveCmd+ = MoveCmd+ { movePieceNumber :: Word8 -- ^ number between 1 and 15+ , moveTargetRow :: RowNumber+ , moveTargetModifier :: Maybe TargetModifier+ } deriving (Show, Eq)++showMoveCmd :: MoveCmd -> T.Text+showMoveCmd moveCmd =+ showPieceNumber (movePieceNumber moveCmd) <>+ T.pack (show (unRowNumber (moveTargetRow moveCmd))) <>+ maybe "" showTargetModifier (moveTargetModifier moveCmd)++moveCmdParser :: P.Parsec P.Dec T.Text MoveCmd+moveCmdParser =+ MoveCmd+ <$> (pieceNumberParser <* P.space)+ <*> targetRowParser+ <*> P.optional (P.try (P.space *> targetModifierParser))+ where+ nonNegativeIntParser =+ RowNumber . read <$> P.some P.digitChar P.<?> "non negative integer"+ targetRowParser = nonNegativeIntParser++parseMoveCmd :: T.Text -> Either String MoveCmd+parseMoveCmd text =+ first P.parseErrorPretty $+ P.runParser moveCmdLineParser "halma move cmd" text+ where+ moveCmdLineParser = (P.space *> moveCmdParser) <* P.space <* P.eof++movesToRow+ :: RuleOptions+ -> HalmaBoard+ -> (Int, Int)+ -> Int+ -> [(TargetModifier, Move)]+movesToRow rules board startPos targetRow =+ let+ allEndPos = possibleMoves rules board startPos+ endPosInTargetRow = filter isInTargetRow allEndPos+ sortedEndPos = sortBy compareByXCoord endPosInTargetRow+ sortedMoves = mkMoveTo <$> sortedEndPos+ in+ tagWithTargetModifier sortedMoves+ where+ isInTargetRow (_x, y) = y == targetRow+ mkMoveTo endPos = Move { moveFrom = startPos, moveTo = endPos }+ compareByXCoord (x1, _) (x2, _) = compare x1 x2++moveToMoveCmd+ :: RuleOptions+ -> HalmaBoard+ -> Move+ -> Maybe MoveCmd+moveToMoveCmd rules board move = do+ let+ startPos = moveFrom move+ piece <- lookupHalmaBoard startPos board+ let+ targetRow = getRow (moveTo move)+ movesToTargetRow = movesToRow rules board startPos targetRow+ targetModifier <- lookup move (map swap movesToTargetRow)+ Just $+ MoveCmd+ { movePieceNumber = pieceNumber piece+ , moveTargetRow = internalToHumanRowNumber (getGrid board) targetRow+ , moveTargetModifier = Just targetModifier+ }+ where+ getRow (_x, y) = y+++data CheckMoveCmdResult+ = MoveImpossible String+ | MoveFoundUnique Move+ | MoveSuggestions (NonEmpty (MoveCmd, Move))+ deriving (Show, Eq)++checkMoveCmd+ :: RuleOptions+ -> HalmaBoard+ -> Team+ -> MoveCmd+ -> CheckMoveCmdResult+checkMoveCmd rules board player moveCmd =+ case lookup pieceToMove allPieces of+ Nothing ->+ MoveImpossible $+ "Unexpected error: The piece " ++ show pieceToMove +++ " is not on the Halma board!"+ Just startPos ->+ let+ mkMoveCmd tm = moveCmd { moveTargetModifier = Just tm }+ movesToTargetRow = movesToRow rules board startPos targetRow+ in+ case first mkMoveCmd <$> movesToTargetRow of+ [] ->+ MoveImpossible $+ "The selected piece can't be moved to row " +++ show (unRowNumber (moveTargetRow moveCmd)) ++ "!"+ [(moveCmd', move)] ->+ case moveTargetModifier moveCmd of+ Nothing ->+ MoveFoundUnique move+ Just (TargetModifier 0) ->+ MoveFoundUnique move+ Just (TargetModifier _) ->+ MoveSuggestions $ pure (moveCmd', move)+ firstMove:restMoves@(_:_) ->+ let+ mMove = do+ targetModifier <- moveTargetModifier moveCmd+ lookup targetModifier movesToTargetRow+ in+ case mMove of+ Just move -> MoveFoundUnique move+ Nothing -> MoveSuggestions (firstMove :| restMoves)++ where+ allPieces = swap <$> M.toList (toMap board)+ pieceToMove =+ Piece+ { pieceTeam = player+ , pieceNumber = movePieceNumber moveCmd+ }+ targetRow = humanToInternalRowNumber (getGrid board) (moveTargetRow moveCmd)
+ src/Game/Halma/TelegramBot/Model/Types.hs view
@@ -0,0 +1,293 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}++module Game.Halma.TelegramBot.Model.Types+ ( Player (..)+ , PartyResult (..)+ , ExtendedPartyResult (..)+ , GameResult (..)+ , HalmaState (..)+ , Party (..)+ , Match (..)+ , MatchState (..)+ , ChatId+ , PlayersSoFar (..)+ , LocaleId (..)+ , HalmaChat (..)+ ) where++import Game.Halma.Board+import Game.Halma.Configuration+import Game.Halma.Rules+import Game.TurnCounter++import Data.Aeson ((.=), (.:))+import Control.Applicative ((<|>))+import qualified Data.Aeson as A+import qualified Data.Text as T+import qualified Data.Vector as V+import qualified Web.Telegram.API.Bot as TG++-- TODO: remove this orphan instance+deriving instance Eq TG.User++data Player+ = AIPlayer+ | TelegramPlayer TG.User+ deriving (Eq, Show)++instance A.ToJSON Player where+ toJSON = \case+ AIPlayer -> "AIPlayer"+ TelegramPlayer user -> A.toJSON user++instance A.FromJSON Player where+ parseJSON = \case+ A.String "AIPlayer" -> pure AIPlayer+ other -> TelegramPlayer <$> A.parseJSON other++data PartyResult+ = PartyResult+ { prParty :: Party+ , prNumberOfTurns :: Int+ } deriving (Eq, Show)++instance A.ToJSON PartyResult where+ toJSON pr =+ A.object+ [ "party" .= prParty pr+ , "number_of_turns" .= prNumberOfTurns pr+ ]++instance A.FromJSON PartyResult where+ parseJSON =+ A.withObject "PartyResult" $ \o -> do+ prParty <- o .: "party"+ prNumberOfTurns <- o .: "number_of_turns"+ pure PartyResult {..}++data ExtendedPartyResult+ = ExtendedPartyResult+ { eprPartyResult :: PartyResult+ , eprPlace :: Int -- ^ zero-based position+ , eprPlaceShared :: Bool -- ^ has another player finished in the same round?+ , eprLag :: Int -- ^ number of moves after winner+ , eprNumberOfPlayers :: Int+ } deriving (Eq, Show)++newtype GameResult+ = GameResult+ { grNumberOfMoves :: [PartyResult]+ } deriving (Show)++instance A.ToJSON GameResult where+ toJSON gameResult =+ A.object+ [ "number_of_moves" .= grNumberOfMoves gameResult+ ]++instance A.FromJSON GameResult where+ parseJSON =+ A.withObject "GameResult" $ \o ->+ GameResult <$> o .: "number_of_moves"++data Party+ = Party+ { partyHomeCorner :: HalmaDirection+ , partyPlayer :: Player+ } deriving (Show, Eq)++instance A.ToJSON Party where+ toJSON party =+ A.object+ [ "home_corner" .= partyHomeCorner party+ , "player" .= partyPlayer party+ ]++instance A.FromJSON Party where+ parseJSON =+ A.withObject "Party" $ \o -> do+ homeCorner <- o .: "home_corner"+ player <- o .: "player"+ pure Party { partyHomeCorner = homeCorner, partyPlayer = player }++data HalmaState+ = HalmaState+ { hsBoard :: HalmaBoard+ , hsTurnCounter :: TurnCounter Party+ , hsLastMove :: Maybe Move+ , hsFinished :: [PartyResult]+ } deriving (Eq, Show)++instance A.ToJSON HalmaState where+ toJSON game =+ A.object+ [ "board" .= hsBoard game+ , "parties" .= tcPlayers (hsTurnCounter game)+ , "total_moves" .= tcCounter (hsTurnCounter game)+ , "last_move" .= hsLastMove game+ , "finished" .= hsFinished game+ ]++instance A.FromJSON HalmaState where+ parseJSON =+ A.withObject "HalmaState" $ \o -> do+ hsBoard <- o .: "board"+ tcPlayers <- o .: "parties"+ tcCounter <- o .: "total_moves"+ hsLastMove <- o .: "last_move"+ hsFinished <- o .: "finished"+ let hsTurnCounter = TurnCounter {..}+ pure HalmaState {..}++data Match+ = Match+ { matchConfig :: Configuration Player+ , matchRules :: RuleOptions+ , matchHistory :: [GameResult]+ , matchCurrentGame :: Maybe HalmaState+ } deriving (Show)++instance A.ToJSON Match where+ toJSON match =+ A.object+ [ "config" .= matchConfig match+ , "rules" .= matchRules match+ , "history" .= matchHistory match+ , "current_game" .= matchCurrentGame match+ ]++instance A.FromJSON Match where+ parseJSON =+ A.withObject "Match size" $ \o -> do+ config <- o .: "config"+ rules <- o .: "rules"+ history <- o .: "history"+ currentGame <- o .: "current_game"+ pure+ Match+ { matchConfig = config+ , matchRules = rules+ , matchHistory = history+ , matchCurrentGame = currentGame+ }++data PlayersSoFar a+ = NoPlayers+ | OnePlayer a+ | EnoughPlayers (Configuration a)+ deriving (Show)++instance A.ToJSON a => A.ToJSON (PlayersSoFar a) where+ toJSON =+ \case+ NoPlayers -> A.Array mempty+ OnePlayer p -> A.toJSON [p]+ EnoughPlayers config -> A.toJSON config++instance A.FromJSON a => A.FromJSON (PlayersSoFar a) where+ parseJSON val =+ parseEnoughPlayers val <|> parseTooFewPlayers val+ where+ parseEnoughPlayers v =+ EnoughPlayers <$> A.parseJSON v+ parseTooFewPlayers =+ A.withArray "PlayersSoFar" $ \v ->+ case V.length v of+ 0 -> pure NoPlayers+ 1 -> OnePlayer <$> A.parseJSON (V.head v)+ _ -> fail "expected an array of length 1 or 2"++data MatchState+ = NoMatch+ | GatheringPlayers (PlayersSoFar Player)+ | MatchRunning Match+ deriving (Show)++instance A.ToJSON MatchState where+ toJSON =+ \case+ NoMatch ->+ A.object [ "state" .= ("no_match" :: T.Text) ]+ GatheringPlayers playersSoFar ->+ A.object+ [ "state" .= ("gathering_players" :: T.Text)+ , "players_so_far" .= playersSoFar+ ]+ MatchRunning match ->+ A.object+ [ "state" .= ("match_running" :: T.Text)+ , "match" .= match+ ]++instance A.FromJSON MatchState where+ parseJSON =+ A.withObject "MatchState" $ \o -> do+ state <- o .: "state"+ case state :: T.Text of+ "no_match" ->+ pure NoMatch+ "gathering_players" ->+ GatheringPlayers <$> (o .: "players_so_far")+ "match_running" ->+ MatchRunning <$> (o .: "match")+ _other ->+ fail $ "unexpected state: " ++ T.unpack state++data LocaleId+ = En+ | De+ deriving (Show, Eq, Bounded, Enum)++showLocaleId :: LocaleId -> T.Text+showLocaleId localeId =+ case localeId of+ En -> "en"+ De -> "de"++parseLocaleId :: T.Text -> Maybe LocaleId+parseLocaleId text =+ case T.toLower text of+ "de" -> Just De+ "en" -> Just En+ _ -> Nothing++instance A.ToJSON LocaleId where+ toJSON = A.String . showLocaleId++instance A.FromJSON LocaleId where+ parseJSON =+ A.withText "LocaleId" $ \t ->+ case parseLocaleId t of+ Nothing -> fail "unrecognized locale id"+ Just localeId -> pure localeId++type ChatId = Integer++data HalmaChat+ = HalmaChat+ { hcId :: ChatId+ , hcLocale :: LocaleId+ , hcMatchState :: MatchState+ } deriving (Show)++instance A.ToJSON HalmaChat where+ toJSON HalmaChat {..} =+ A.object+ [ "id" .= hcId+ , "locale" .= hcLocale+ , "match_state" .= hcMatchState+ ]++instance A.FromJSON HalmaChat where+ parseJSON =+ A.withObject "HalmaChat" $ \o -> do+ hcId <- o .: "id"+ hcLocale <- o .: "locale"+ hcMatchState <- o .: "match_state"+ pure HalmaChat {..}
+ src/Game/Halma/TelegramBot/View.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE OverloadedStrings #-}++module Game.Halma.TelegramBot.View+ ( module Game.Halma.TelegramBot.View.DrawBoard+ , module Game.Halma.TelegramBot.View.I18n+ , module Game.Halma.TelegramBot.View.Pretty+ ) where++import Game.Halma.TelegramBot.Model+import Game.Halma.TelegramBot.View.DrawBoard+import Game.Halma.TelegramBot.View.I18n+import Game.Halma.TelegramBot.View.Pretty
+ src/Game/Halma/TelegramBot/View/DrawBoard.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE FlexibleContexts #-}++module Game.Halma.TelegramBot.View.DrawBoard+ ( BoardLabels+ , withRenderedBoardInPngFile+ ) where++import Game.Halma.Board+import Game.Halma.Board.Draw+import Game.Halma.TelegramBot.Model.MoveCmd+import Game.Halma.TelegramBot.Model.Types++import Control.Monad.Catch (MonadMask)+import Control.Monad.IO.Class (MonadIO (..))+import Diagrams.Backend.Cairo (Cairo, renderCairo)+import Diagrams.Prelude ((#), (|||), (*^), (&), (.~))+import Diagrams.Query (resetValue)+import Diagrams.Size (dims)+import Diagrams.TwoD.Types (V2 (..))+import System.Directory (getTemporaryDirectory)+import System.IO (hClose)+import System.IO.Temp (withTempFile)+import qualified Data.Text as T+import qualified Data.Map as M+import qualified Diagrams.Prelude as D++type BoardLabels = M.Map (Int, Int) T.Text++withRenderedBoardInPngFile+ :: (MonadIO m, MonadMask m)+ => HalmaState+ -> BoardLabels+ -> (FilePath -> m a)+ -> m a+withRenderedBoardInPngFile game labels action =+ withTempPngFilePath $ \path -> do+ let+ dia = drawBoardForChat game labels # D.centerXY # D.pad 1.1+ bounds = dims (V2 1000 1000)+ liftIO $ renderCairo path bounds dia+ action path+ where+ withTempPngFilePath handler = do+ systemTempDir <- liftIO getTemporaryDirectory+ withTempFile systemTempDir "halma.png" $ \filePath fileHandle -> do+ liftIO (hClose fileHandle)+ handler filePath++drawBoardForChat :: HalmaState -> BoardLabels -> D.Diagram Cairo+drawBoardForChat game labels =+ let+ boardDia = resetValue (drawBoard' (getGrid board) drawField)+ in+ scale ||| D.strut D.unitX ||| boardDia ||| D.strut D.unitX ||| scale+ where+ board = hsBoard game+ dirY = D.rotateBy (1/6) D.unitX+ rowDir = dirY & D._x .~ 0+ boardFontStyle x = x # D.fontSize (D.output 22) # D.font "Arial"+ scale = D.position $ map rowMarker [(-r)..r]+ where+ r = radiusInRows (getGrid board)+ rowMarker i = (rowPosition i, rowNumberLabel i)+ rowPosition i = D.p2 $ D.unr2 $ fromIntegral i *^ rowDir+ rowNumberLabel i =+ let+ humanRowNumber = internalToHumanRowNumber (getGrid board) i+ txt = show (unRowNumber humanRowNumber)+ in+ D.text txt # boardFontStyle # D.fc D.gray+ drawField :: (Int, Int) -> D.Diagram Cairo+ drawField field =+ case lookupHalmaBoard field board of+ Just piece ->+ if Just field == (moveTo <$> hsLastMove game) then+ drawPiece piece # D.lc D.black # D.lw D.medium+ else+ drawPiece piece+ Nothing ->+ case M.lookup field labels of+ Just label -> drawLabel label+ Nothing -> mempty+ drawPiece :: Piece -> D.Diagram Cairo+ drawPiece piece =+ let+ c = defaultTeamColours (pieceTeam piece)+ symbol = T.unpack (showPieceNumber (pieceNumber piece))+ text = D.text symbol # boardFontStyle # D.fc D.white+ circle = D.circle 0.3 # D.fc c+ in+ text `D.atop` circle+ drawLabel :: T.Text -> D.Diagram Cairo+ drawLabel label =+ let+ text = D.text (T.unpack label) # boardFontStyle # D.fc D.gray+ circle = D.circle 0.3 # D.fc D.white+ in+ text `D.atop` circle
+ src/Game/Halma/TelegramBot/View/I18n.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Game.Halma.TelegramBot.View.I18n+ ( HalmaLocale (..)+ , NotYourTurnInfo (..)+ , CantUndoReason (..)+ , AIMove (..)+ , enHalmaLocale+ , deHalmaLocale+ , LocaleId (..)+ , allLocaleIds+ , localeById+ ) where++import Game.Halma.Board (HalmaDirection)+import Game.Halma.TelegramBot.Model.Types+import Game.Halma.TelegramBot.View.Pretty+import Game.Halma.TelegramBot.Model.MoveCmd++import Data.Char (toUpper)+import Data.Monoid ((<>))+import qualified Data.Aeson as A+import qualified Data.Text as T+import qualified Web.Telegram.API.Bot as TG++data NotYourTurnInfo+ = NotYourTurnInfo+ { you :: TG.User+ , thePlayerWhoseTurnItIs :: Player+ }++data CantUndoReason+ = CantUndoNoGame++data AIMove+ = AIMove+ { aiHomeCorner :: HalmaDirection+ , aiMoveCmd :: MoveCmd+ }++data HalmaLocale+ = HalmaLocale+ { hlWelcomeMsg :: T.Text+ , hlHelpMsg :: T.Text+ , hlCongratulation :: ExtendedPartyResult -> T.Text+ , hlCantStartNewRoundBecauseNoMatch :: T.Text+ , hlStartingANewRound :: T.Text+ , hlYourTurn :: HalmaDirection -> TG.User -> T.Text+ , hlNotYourTurn :: NotYourTurnInfo -> T.Text+ , hlCantUndo :: Maybe CantUndoReason -> T.Text+ , hlAIMove :: AIMove -> T.Text+ , hlNoMatchMsg :: T.Text+ , hlNoRoundMsg :: T.Text+ }++-- | English+enHalmaLocale :: HalmaLocale+enHalmaLocale =+ HalmaLocale+ { hlWelcomeMsg =+ "Greetings from HalmaBot! I am an [open-source](https://github.com/timjb/halma) Telegram bot " <>+ "written in Haskell by Tim Baumann <tim@timbaumann.info>."+ , hlHelpMsg =+ "You can control me by sending these commands:\n" <>+ "/newmatch — starts a new match between two or three players\n" <>+ "/newround — start a new game round\n" <>+ "/undo — reverse your last move\n" <>+ "/setlang [" <> localesText <> "] — switch to another language\n" <>+ "/help — display this message\n\n" <>+ "Here's how move commands are structured:\n" <>+ "First there comes a letter in the range A-O (the piece you want to " <>+ " move), then the number of the row you want to move the piece to. " <>+ "If there are multiple possible target positions on the row, I will " <>+ "ask you which one you mean.\n" <>+ "For example: the command 'a11' makes me move your piece labeled 'a' " <>+ "to row number 11."+ , hlCongratulation = congrat+ , hlCantStartNewRoundBecauseNoMatch =+ "Can't start a new round, because there is no match running. You have to start a /newmatch first."+ , hlStartingANewRound =+ "starting a new round!"+ , hlYourTurn = \homeCorner user ->+ prettyUser user <> " " <> teamEmoji homeCorner <> " it's your turn!"+ , hlNotYourTurn = \notYourTurn ->+ "Hey " <> prettyUser (you notYourTurn) <> ", it's not your turn, it's " <>+ prettyPlayer (thePlayerWhoseTurnItIs notYourTurn) <> "'s!"+ , hlCantUndo = \case+ Nothing -> "can't undo!"+ Just CantUndoNoGame -> "can't undo: no game running!"+ , hlAIMove = \aiMove ->+ "The AI " <> teamEmoji (aiHomeCorner aiMove) <>+ " makes the following move: " <> showMoveCmd (aiMoveCmd aiMove)+ , hlNoMatchMsg =+ "Start a new Halma match with /newmatch"+ , hlNoRoundMsg =+ "Start a new round with /newround"+ }+ where+ nominal i =+ case i of+ 1 -> "first"+ 2 -> "second"+ 3 -> "third"+ 4 -> "fourth"+ 5 -> "fifth"+ 6 -> "sixth"+ _ -> "(error: unexpected integer)"+ deficitMsg result =+ "with a deficit of " <> T.pack (show (eprLag result)) <> " moves"+ congrat result =+ let+ party = prParty $ eprPartyResult result+ in+ case (partyPlayer party, eprPlace result) of+ (AIPlayer, i) ->+ "The AI " <> teamEmoji (partyHomeCorner party) <> " finishes " <>+ nominal (i+1) <>+ (if i == 0 then "" else " " <> deficitMsg result)+ (TelegramPlayer user, 0) ->+ prettyUser user <> ", " <>+ "congratulations on your " <>+ (if eprPlaceShared result then "shared " else "") <>+ "first place \127941" -- unicode symbol: sports medal+ (TelegramPlayer user, i) ->+ prettyUser user <> ", " <>+ "you are " <> nominal (i+1) <>+ " " <> deficitMsg result++-- | German (deutsch)+deHalmaLocale :: HalmaLocale+deHalmaLocale =+ HalmaLocale+ { hlWelcomeMsg =+ "Hallo, ich bin @HalmaBot, ein [quelloffener](https://github.com/timjb/halma) Telegram-Bot " <>+ " programmiert von Tim Baumann <tim@timbaumann.info> in Haskell."+ , hlHelpMsg =+ "Du kannst mich durch folgende Kommandos steuern:\n" <>+ "/newmatch — startet ein neues Halma-Match\n" <>+ "/newround — startet eine neue Spielrunde im aktuellen Match\n" <>+ "/undo — macht den letzten Zug rückgängig\n" <>+ "/setlang [" <> localesText <> "] — wechsle die Sprache / switch to another language\n" <>+ "/help — zeigt diese Hilfe-Nachricht an\n\n" <>+ "Zuganweisungen sind folgendermaßen aufgebaut:\n" <>+ "Zuerst kommt ein Buchstabe von A bis O (der Spielstein, den du " <>+ " bewegen möchtest), dann kommt die Nummer der Reihe in den du den " <>+ " Stein bewegen möchtest. " <>+ "Wenn es mehrere mögliche Zielpositionen innerhalb dieser Reihe gibt, " <>+ "dann frage ich dich, welche du genau meinst.\n" <>+ "Zum Beispiel: Das Kommando 'a11' bewegt deinen Stein mit der " <>+ "Aufschrift 'a' in die Zeile Nummer 11."+ , hlCongratulation = congrat+ , hlCantStartNewRoundBecauseNoMatch =+ "Um eine neue Runde zu starten, muss erst ein neues Spiel mit /newmatch gestartet werden."+ , hlStartingANewRound =+ "Neue Runde!"+ , hlYourTurn = \homeCorner user ->+ prettyUser user <> " " <> teamEmoji homeCorner <> ", du bist dran!"+ , hlNotYourTurn = \notYourTurn ->+ "Hey " <> prettyUser (you notYourTurn) <> ", du bist nicht an der Reihe, sondern " <>+ prettyPlayer (thePlayerWhoseTurnItIs notYourTurn) <> "!"+ , hlCantUndo = \case+ Nothing -> "'undo' nicht möglich!"+ Just CantUndoNoGame -> "'undo' nicht möglich: es ist gerade kein Spiel am Laufen!"+ , hlAIMove = \aiMove ->+ "Die KI " <> teamEmoji (aiHomeCorner aiMove) <>+ " macht den folgenden Zug: " <> showMoveCmd (aiMoveCmd aiMove)+ , hlNoMatchMsg =+ "Starte ein neues Halma-Match mit /newmatch"+ , hlNoRoundMsg =+ "Starte eine neue Runde mit /newround"+ }+ where+ nominal i =+ case i of+ 1 -> "erster"+ 2 -> "zweiter"+ 3 -> "dritter"+ 4 -> "vierter"+ 5 -> "fünfter"+ 6 -> "sechster"+ _ -> "(Fehler: unerwartete Zahl)"+ deficitMsg result =+ "mit einem Rückstand von " <>+ T.pack (show (eprLag result)) <>+ " Zügen"+ congrat result =+ let+ party = prParty $ eprPartyResult result+ in+ case (partyPlayer party, eprPlace result) of+ (AIPlayer, i) ->+ "Die KI " <> teamEmoji (partyHomeCorner party) <> " wird " <>+ (if eprPlaceShared result then "ebenfalls " else "") <>+ capitalize (nominal (i+1)) <>+ (if i == 0 then "" else " " <> deficitMsg result)+ (TelegramPlayer user, 0) ->+ prettyUser user <> ", " <>+ "Glückwunsch zum " <>+ (if eprPlaceShared result then "geteilten " else "") <>+ "ersten Platz \127941" -- unicode symbol: sports medal+ (TelegramPlayer user, i) ->+ prettyUser user <> ", " <>+ "du bist " <>+ (if eprPlaceShared result then "auch " else "") <>+ capitalize (nominal (i+1)) <>+ " " <> deficitMsg result++capitalize :: T.Text -> T.Text+capitalize t =+ if T.null t then+ t+ else+ toUpper (T.head t) `T.cons` T.tail t++allLocaleIds :: [LocaleId]+allLocaleIds = [En, De]++localesText :: T.Text+localesText = T.intercalate " / " (map prettyLocaleId allLocaleIds)++localeById :: LocaleId -> HalmaLocale+localeById localeId =+ case localeId of+ En -> enHalmaLocale+ De -> deHalmaLocale
+ src/Game/Halma/TelegramBot/View/Pretty.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE OverloadedStrings #-}++module Game.Halma.TelegramBot.View.Pretty+ ( prettyUser+ , prettyPlayer+ , prettyLocaleId+ , parsePrettyLocaleId+ , teamEmoji+ ) where++import Game.Halma.Board+import Game.Halma.TelegramBot.Model.Types++import Data.Monoid ((<>))+import qualified Data.Text as T+import qualified Web.Telegram.API.Bot as TG++prettyUser :: TG.User -> T.Text+prettyUser user =+ case TG.user_username user of+ Just username -> "@" <> username+ Nothing ->+ TG.user_first_name user <>+ maybe "" (" " <>) (TG.user_last_name user)++prettyPlayer :: Player -> T.Text+prettyPlayer player =+ case player of+ AIPlayer -> "AI"+ TelegramPlayer user -> prettyUser user++prettyLocaleId :: LocaleId -> T.Text+prettyLocaleId localeId = + case localeId of+ De -> "\127465\127466 de" -- german flag :de:+ En -> "\127468\127463 en" -- union jack :gb:++parsePrettyLocaleId :: T.Text -> Maybe LocaleId+parsePrettyLocaleId s =+ lookup (T.strip s) table+ where+ table = map (\locId -> (prettyLocaleId locId, locId)) [minBound..maxBound]+ +teamEmoji :: Team -> T.Text+teamEmoji dir =+ case dir of+ North -> "\128309" -- :large_blue_circle: for blue+ Northeast -> "\128154" -- :green_heart: for green+ Northwest -> "\128156" -- :purple_heart: for purple+ South -> "\128308" -- :red_circle: for red+ Southeast -> "\9899" -- :medium_black_circle: for black+ Southwest -> "\128310" -- :large_orange_diamond: for orange
+ src/Main.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}++module Main where++import Game.Halma.TelegramBot.CmdLineOptions+import Game.Halma.TelegramBot.Controller (halmaBot)+import Game.Halma.TelegramBot.Controller.BotM (evalGlobalBotM)+import Game.Halma.TelegramBot.Controller.Types (BotConfig (..))++import Network.HTTP.Client (newManager)+import Network.HTTP.Client.TLS (tlsManagerSettings)+import qualified Options.Applicative as OA++main :: IO ()+main = do+ opts <- OA.execParser optionsParserInfo+ manager <- newManager tlsManagerSettings+ let+ cfg = + BotConfig+ { bcToken = boToken opts+ , bcOutputDirectory = boOutputDirectory opts+ , bcManager = manager+ }+ print opts+ evalGlobalBotM halmaBot cfg+