Haskell中如何使用Machines库建立双向关联的玩家与游戏阶段状态机

我正在使用Machines库建模一款回合制游戏，目前不知道如何连接玩家和游戏阶段状态机，以满足以下要求：

• 当处于Active状态的玩家执行Act操作时，游戏推进到下一阶段。
• 当游戏阶段推进后，玩家状态会重置为NotActedThisTurn。

目前已实现的代码 #

游戏基础定义 #

import Data.Machine

data Stage = One | Two deriving (Show, Eq, Ord)

规则为所有玩家在当前阶段都已行动时，游戏阶段就会推进：

data TurnStatus = AllPlayersActed | NotAllPlayersActed deriving (Eq, Show, Ord)

游戏阶段状态机 #

仅当当前阶段所有玩家都已行动时，游戏阶段才会推进：

newHand :: Mealy TurnStatus Stage
newHand = Mealy toOne

toOne :: TurnStatus -> (Stage, Mealy TurnStatus Stage)
toOne AllPlayersActed = (One, Mealy toTwo)
toOne NotAllPlayersActed = (One, Mealy toOne)

toTwo :: TurnStatus -> (Stage, Mealy TurnStatus Stage)
toTwo AllPlayersActed = (Two, Mealy toOne)
toTwo NotAllPlayersActed = (One, Mealy toTwo)

stageMachine :: Monad m => MachineT m (Is TurnStatus) Stage
stageMachine = auto newHand

回合状态追踪状态机 #

用于追踪当前回合是否所有玩家都已行动：

initTurnStatus :: Mealy Player TurnStatus
initTurnStatus = Mealy nextTurnStatus

nextTurnStatus :: Player -> (TurnStatus, Mealy Player TurnStatus)
nextTurnStatus _ = (NotAllPlayersActed, Mealy nextTurnStatus)

turnStatusMachine :: Monad m => MachineT m (Is Player) TurnStatus
turnStatusMachine = auto initTurnStatus

玩家与操作相关定义 #

data Action = Activate | Deactivate | Act deriving (Show, Eq, Ord)

data HasActed = ActedThisTurn | NotActedThisTurn deriving (Show, Eq, Ord)

data PlayerStatus = Active HasActed | Inactive deriving (Show, Eq, Ord)

data Player = Player String PlayerStatus deriving (Show, Eq, Ord)

initPlayer :: String -> Player
initPlayer n = Player n (Active NotActedThisTurn)

playerMealy :: Player -> Action -> (Either String Action, Player)
playerMealy (Player name Inactive) Activate =
    (Right Activate, Player name $ Active NotActedThisTurn)
playerMealy (Player name (Active _)) Activate = 
    (Left "couldnt activate as already active", Player name $ Active NotActedThisTurn)

playerMealy (Player name (Active _)) Deactivate = 
    (Right Deactivate, Player name Inactive)
playerMealy (Player name Inactive) Deactivate = 
    (Left "couldnt deactivate as already inactive", Player name Inactive)

playerMealy (Player name Inactive) Act = 
    (Left "couldnt act since inactive", Player name Inactive)
playerMealy (Player name (Active ActedThisTurn)) Act = 
    (Left "already acted this turn", Player name Inactive)
playerMealy (Player name (Active _)) Act = 
    (Right Act, Player name $ Active ActedThisTurn)

playerMealy' :: String -> Mealy Action (Either String Action)
playerMealy' name = unfoldMealy playerMealy $ initPlayer name

playerMachine :: Monad m => String -> MachineT m (Is Action) (Either String Action)
playerMachine = auto . playerMealy'

runPlayerMachine :: Monad m => String -> MachineT m (Is Action) (Either String Action)
runPlayerMachine name = source [Activate, Act] ~> playerMachine name

连接实现方案 #

你可以通过补充事件流转逻辑、扩展玩家状态机输入的方式串联所有模块：

1. 统一事件类型 #

定义全局事件类型用来流转不同节点的信号：

data GameEvent = PlayerAction String Action | StageUp Stage | ResetPlayer

2. 扩展玩家状态机支持重置 #

调整玩家状态机输入类型，兼容阶段推进后的重置指令：

data PlayerInput = RunAction Action | ResetActedStatus

-- 调整后的玩家状态机逻辑，原有操作逻辑不变，新增重置分支
playerMealy :: Player -> PlayerInput -> (Either String (Maybe Action), Player)
playerMealy p ResetActedStatus = (Right Nothing, resetActStatus p)
  where resetActStatus (Player name (Active _)) = Player name $ Active NotActedThisTurn
        resetActStatus p = p
playerMealy p (RunAction act) = let (res, newP) = oldPlayerMealy p act in (fmap Just res, newP)
  where oldPlayerMealy = 原有未修改的playerMealy函数

3. 顶层组合状态机 #

用Machines库的组合子串联所有子状态机，实现完整流程：

fullGame :: Monad m => [String] -> MachineT m (Is GameEvent) Stage
fullGame playerList = playerGroup ~> turnStatusMachine ~> stageMachine ~> feedbackReset
  where
    -- 合并所有玩家状态机
    playerGroup = wyeMap (\case PlayerAction n a -> (n, RunAction a)) $ map (\n -> (n, playerMachine n)) playerList
    -- 阶段更新时广播重置信号给所有玩家
    feedbackReset = tapped (\newStage -> yield $ StageUp newStage) ~> auto (const ResetPlayer) ~> playerGroup

内容的提问来源于stack exchange，提问作者therewillbecode