mirror of
https://github.com/marcosh/crem.git
synced 2024-09-11 12:36:19 +03:00
Decider can be rebuilt out of its own outputs
This commit is contained in:
parent
657141b8d5
commit
432cf8ad6c
55
spec/Crem/DeciderSpec.hs
Normal file
55
spec/Crem/DeciderSpec.hs
Normal file
@ -0,0 +1,55 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module Crem.DeciderSpec where
|
||||
|
||||
import "crem" Crem.BaseMachine (InitialState (..))
|
||||
import "crem" Crem.Decider
|
||||
import "crem" Crem.Example.Uno
|
||||
import Crem.StateMachine (StateMachineT (..), run)
|
||||
import Data.Functor.Identity (Identity)
|
||||
import "hspec" Test.Hspec (Spec, describe, it, shouldBe)
|
||||
|
||||
spec :: Spec
|
||||
spec =
|
||||
describe "Decider" $ do
|
||||
describe "unoDecider" $ do
|
||||
it "is able to rebuild from a list of events" $ do
|
||||
let
|
||||
unoInitialDecider :: Decider UnoTopology Command (Either GameError Event)
|
||||
unoInitialDecider = unoDecider (InitialState UnoInitialState)
|
||||
|
||||
rebuiltDecider :: Decider UnoTopology Command (Either GameError Event)
|
||||
rebuiltDecider =
|
||||
rebuildDecider
|
||||
[ Right $
|
||||
GameStarted
|
||||
(InitialData (PlayerCount 3) (DigitCard Three Yellow))
|
||||
(PlayerId 0)
|
||||
, Right $
|
||||
CardPlayed
|
||||
(PlayData (PlayerId 0) (DigitCard Six Yellow))
|
||||
]
|
||||
unoInitialDecider
|
||||
|
||||
inProgressDecider :: Decider UnoTopology Command (Either GameError Event)
|
||||
inProgressDecider =
|
||||
unoDecider
|
||||
( InitialState $
|
||||
UnoStartedState $
|
||||
StateData
|
||||
{ topCard = DigitCard Six Yellow
|
||||
, currentPlayer = Player (PlayerId 0) (PlayerCount 3) Clockwise
|
||||
}
|
||||
)
|
||||
|
||||
command :: Command
|
||||
command =
|
||||
PlayCard $
|
||||
PlayData
|
||||
{ playerId = PlayerId 1
|
||||
, card = DigitCard Six Blue
|
||||
}
|
||||
in
|
||||
(fst <$> run @Identity (Basic $ deciderMachine rebuiltDecider) command)
|
||||
`shouldBe` (fst <$> run (Basic $ deciderMachine inProgressDecider) command)
|
@ -1,11 +1,11 @@
|
||||
module Crem.StateMachineSpec where
|
||||
|
||||
import "base" Control.Category qualified
|
||||
import Crem.Example.BooleanStateMachine (booleanStateMachine)
|
||||
import Crem.Example.LockDoor
|
||||
import Crem.Example.PlusOneUpToFour (plus1UpTo4)
|
||||
import Crem.Example.Switch (switchMachine)
|
||||
import "crem" Crem.StateMachine
|
||||
import "base" Control.Category qualified
|
||||
import "base" Data.Functor.Identity (Identity (..))
|
||||
import "base" Data.List (singleton)
|
||||
import "profunctors" Data.Profunctor (rmap)
|
||||
@ -15,13 +15,6 @@ import "hspec" Test.Hspec (Expectation, Spec, describe, it, shouldBe)
|
||||
shouldOutput :: (Eq b, Show b) => Identity (b, c) -> b -> Expectation
|
||||
shouldOutput (Identity (output, _)) expectedOutput = output `shouldBe` expectedOutput
|
||||
|
||||
shouldHaveTheSameOutputAs
|
||||
:: (Eq b, Show b)
|
||||
=> (b, c)
|
||||
-> (b, c)
|
||||
-> Expectation
|
||||
shouldHaveTheSameOutputAs (b1, _) (b2, _) = b1 `shouldBe` b2
|
||||
|
||||
spec :: Spec
|
||||
spec =
|
||||
describe "StateMachine" $ do
|
||||
|
@ -2,8 +2,9 @@
|
||||
|
||||
module Crem.Decider where
|
||||
|
||||
import Crem.BaseMachine (ActionResult (..), BaseMachine, BaseMachineT (..), InitialState)
|
||||
import Crem.BaseMachine (ActionResult (..), BaseMachine, BaseMachineT (..), InitialState (..))
|
||||
import Crem.Topology (AllowedTransition, Topology)
|
||||
import Data.Foldable (foldl')
|
||||
import "base" Data.Kind (Type)
|
||||
|
||||
-- | The [Decider pattern](https://thinkbeforecoding.com/post/2021/12/17/functional-event-sourcing-decider)
|
||||
@ -38,6 +39,7 @@ data
|
||||
=> state finalVertex
|
||||
-> EvolutionResult topology state initialVertex output
|
||||
|
||||
-- | translate a `Decider` into a `BaseMachine`
|
||||
deciderMachine
|
||||
:: Decider topology input output
|
||||
-> BaseMachine topology input output
|
||||
@ -52,3 +54,30 @@ deciderMachine (Decider deciderInitialState' decide' evolve') =
|
||||
EvolutionResult finalState ->
|
||||
ActionResult $ pure (output, finalState)
|
||||
}
|
||||
|
||||
-- | rebuild a `Decider` from a list of outputs
|
||||
--
|
||||
-- This is the main selling point of a `Decider` over a generic `StateMachine`,
|
||||
-- since it allows it to be rebuilt from its outputs.
|
||||
rebuildDecider
|
||||
:: [output]
|
||||
-> Decider topology input output
|
||||
-> Decider topology input output
|
||||
rebuildDecider outputs decider =
|
||||
foldl' rebuildDeciderStep decider outputs
|
||||
where
|
||||
rebuildDeciderStep
|
||||
:: Decider topology input output
|
||||
-> output
|
||||
-> Decider topology input output
|
||||
rebuildDeciderStep (Decider (InitialState initialState') decide' evolve') output =
|
||||
let
|
||||
evolveResult = evolve' initialState' output
|
||||
in
|
||||
case evolveResult of
|
||||
EvolutionResult evolvedState ->
|
||||
Decider
|
||||
{ deciderInitialState = InitialState evolvedState
|
||||
, decide = decide'
|
||||
, evolve = evolve'
|
||||
}
|
||||
|
@ -1,10 +1,16 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# HLINT ignore "Redundant id" #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wmissing-deriving-strategies
|
||||
{-# OPTIONS_GHC -Wno-missing-deriving-strategies #-}
|
||||
-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wunrecognised-pragmas
|
||||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
||||
|
||||
{-# HLINT ignore "Redundant id" #-}
|
||||
-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wunused-type-patterns
|
||||
{-# OPTIONS_GHC -Wno-unused-type-patterns #-}
|
||||
|
||||
-- | Porting of https://github.com/thinkbeforecoding/UnoCore/blob/solution/Uno/Game.fs
|
||||
module Crem.Example.Uno where
|
||||
@ -19,7 +25,7 @@ import Prelude qualified (id)
|
||||
-- * Domain
|
||||
|
||||
newtype PlayerCount = PlayerCount Int
|
||||
deriving newtype (Eq, Ord)
|
||||
deriving newtype (Eq, Ord, Show)
|
||||
|
||||
data Digit
|
||||
= Zero
|
||||
@ -32,20 +38,20 @@ data Digit
|
||||
| Seven
|
||||
| Eigth
|
||||
| Nine
|
||||
deriving stock (Eq)
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
data Colour
|
||||
= Red
|
||||
| Green
|
||||
| Blue
|
||||
| Yellow
|
||||
deriving stock (Eq)
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
data Card
|
||||
= DigitCard Digit Colour
|
||||
| Skip Colour
|
||||
| Kickback Colour
|
||||
deriving stock (Eq)
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
colour :: Card -> Colour
|
||||
colour (DigitCard _ c) = c
|
||||
@ -55,7 +61,6 @@ colour (Kickback c) = c
|
||||
sameColour :: Card -> Card -> Bool
|
||||
sameColour card1 card2 =
|
||||
colour card1 == colour card2
|
||||
|
||||
data CardValue
|
||||
= DigitValue Digit
|
||||
| SkipValue
|
||||
@ -72,7 +77,7 @@ sameValue card1 card2 =
|
||||
value card1 == value card2
|
||||
|
||||
newtype PlayerId = PlayerId Int
|
||||
deriving stock (Eq)
|
||||
deriving newtype (Eq, Show)
|
||||
|
||||
data Direction
|
||||
= Clockwise
|
||||
@ -134,15 +139,20 @@ data InitialData = InitialData
|
||||
{ players :: PlayerCount
|
||||
, firstCard :: Card
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
data PlayData = PlayData
|
||||
{ playerId :: PlayerId
|
||||
, card :: Card
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
data Command
|
||||
= StartGame InitialData
|
||||
| PlayCard PlayData
|
||||
deriving stock (Show)
|
||||
|
||||
-- deriving (Arbitrary) via (GenericArbitrary Command)
|
||||
|
||||
data Event
|
||||
= GameStarted InitialData PlayerId
|
||||
@ -150,6 +160,7 @@ data Event
|
||||
| CardPlayedAndTurnBegan PlayData PlayerId
|
||||
| WrongCardPlayed PlayData
|
||||
| PlayerPlayedAtWrongTurn PlayData
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
-- * Topology
|
||||
|
||||
@ -158,6 +169,7 @@ $( singletons
|
||||
data UnoVertex
|
||||
= Initial
|
||||
| Started
|
||||
deriving stock (Eq, Show, Enum, Bounded)
|
||||
|
||||
unoTopology :: Topology UnoVertex
|
||||
unoTopology = Topology [(Initial, [Started])]
|
||||
@ -181,13 +193,21 @@ data GameError
|
||||
= TooFewPlayers
|
||||
| GameAlreadyStarted
|
||||
| GameNotStarted
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
-- * Machine
|
||||
|
||||
unoDecider :: Decider UnoTopology Command (Either GameError Event)
|
||||
unoDecider =
|
||||
-- | A decider with the logic of the Uno game
|
||||
--
|
||||
-- It emits one event for every transition, not a list of events, because an
|
||||
-- event represents a state transition and a state machine perform one single
|
||||
-- state transition at every step
|
||||
unoDecider
|
||||
:: InitialState UnoState
|
||||
-> Decider UnoTopology Command (Either GameError Event)
|
||||
unoDecider initialState =
|
||||
Decider
|
||||
{ deciderInitialState = InitialState UnoInitialState
|
||||
{ deciderInitialState = initialState
|
||||
, decide = \command state ->
|
||||
case (state, command) of
|
||||
(_, StartGame initialData)
|
||||
|
Loading…
Reference in New Issue
Block a user