mirror of
https://github.com/marcosh/crem.git
synced 2024-09-11 12:36:19 +03:00
move examples into the main package
This commit is contained in:
parent
bb1430eba9
commit
99a85c1727
@ -2,8 +2,8 @@
|
||||
|
||||
module CRM.Example.BooleanStateMachine where
|
||||
|
||||
import "crm" CRM.BaseMachine
|
||||
import "crm" CRM.StateMachine
|
||||
import CRM.BaseMachine
|
||||
import CRM.StateMachine
|
||||
import "singletons-base" Data.Singletons.Base.TH
|
||||
|
||||
booleanStateMachine
|
@ -9,8 +9,8 @@
|
||||
|
||||
module CRM.Example.LockDoor where
|
||||
|
||||
import "crm" CRM.BaseMachine
|
||||
import "crm" CRM.Topology
|
||||
import CRM.BaseMachine
|
||||
import CRM.Topology
|
||||
import "singletons-base" Data.Singletons.Base.TH
|
||||
|
||||
$( singletons
|
@ -3,8 +3,8 @@
|
||||
|
||||
module CRM.Example.OneState where
|
||||
|
||||
import "crm" CRM.BaseMachine
|
||||
import "crm" CRM.Topology
|
||||
import CRM.BaseMachine
|
||||
import CRM.Topology
|
||||
import "singletons-base" Data.Singletons.Base.TH
|
||||
|
||||
oneVertexMachine :: BaseMachine (TrivialTopology @()) () ()
|
@ -2,7 +2,7 @@
|
||||
|
||||
module CRM.Example.PlusOneUpToFour where
|
||||
|
||||
import "crm" CRM.StateMachine (StateMachine, stateless)
|
||||
import CRM.StateMachine (StateMachine, stateless)
|
||||
|
||||
plus1UpTo4 :: StateMachine Int [Int]
|
||||
plus1UpTo4 =
|
@ -7,9 +7,9 @@
|
||||
|
||||
module CRM.Example.RiskManager.Aggregate where
|
||||
|
||||
import "crm" CRM.BaseMachine
|
||||
import CRM.BaseMachine
|
||||
import CRM.Example.RiskManager.Domain
|
||||
import "crm" CRM.Topology
|
||||
import CRM.Topology
|
||||
import "singletons-base" Data.Singletons.Base.TH
|
||||
|
||||
$( singletons
|
@ -4,7 +4,7 @@ import CRM.Example.RiskManager.Aggregate (riskAggregate)
|
||||
import CRM.Example.RiskManager.Domain (RiskCommand, RiskEvent)
|
||||
import CRM.Example.RiskManager.Policy (riskPolicy)
|
||||
import CRM.Example.RiskManager.Projection (ReceivedData, riskProjection)
|
||||
import "crm" CRM.StateMachine
|
||||
import CRM.StateMachine
|
||||
import "base" Data.List (singleton)
|
||||
import "base" Data.Maybe (maybeToList)
|
||||
import "profunctors" Data.Profunctor (rmap)
|
@ -1,7 +1,7 @@
|
||||
module CRM.Example.RiskManager.Policy where
|
||||
|
||||
import CRM.Example.RiskManager.Domain
|
||||
import "crm" CRM.StateMachine
|
||||
import CRM.StateMachine
|
||||
|
||||
riskPolicy :: StateMachine RiskEvent (Maybe RiskCommand)
|
||||
riskPolicy =
|
@ -9,9 +9,9 @@
|
||||
|
||||
module CRM.Example.RiskManager.Projection where
|
||||
|
||||
import "crm" CRM.BaseMachine
|
||||
import CRM.BaseMachine
|
||||
import CRM.Example.RiskManager.Domain
|
||||
import "crm" CRM.Topology
|
||||
import CRM.Topology
|
||||
import "base" Data.Monoid (Last (..))
|
||||
import "singletons-base" Data.Singletons.Base.TH
|
||||
import "base" GHC.Generics (Generic)
|
@ -7,8 +7,8 @@
|
||||
|
||||
module CRM.Example.Switch where
|
||||
|
||||
import "crm" CRM.BaseMachine
|
||||
import "crm" CRM.Topology
|
||||
import CRM.BaseMachine
|
||||
import CRM.Topology
|
||||
import "singletons-base" Data.Singletons.Base.TH
|
||||
|
||||
$( singletons
|
185
src/CRM/Example/TheHobbit.hs
Normal file
185
src/CRM/Example/TheHobbit.hs
Normal file
@ -0,0 +1,185 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# 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 #-}
|
||||
|
||||
module CRM.Example.TheHobbit where
|
||||
|
||||
import CRM.BaseMachine
|
||||
import CRM.Topology
|
||||
import "base" Data.Semigroup
|
||||
import "singletons-base" Data.Singletons.Base.TH
|
||||
|
||||
data HobbitCommand
|
||||
= GoEast
|
||||
| GoWest
|
||||
| GoNorth
|
||||
| GoSouth
|
||||
| Wait
|
||||
| GetKey
|
||||
| UnlockDoor
|
||||
deriving stock (Eq, Read, Show)
|
||||
|
||||
newtype HobbitMessage = HobbitMessage {getMessage :: String}
|
||||
deriving (Semigroup) via (Last HobbitMessage)
|
||||
|
||||
instance Monoid HobbitMessage where
|
||||
mempty = HobbitMessage ""
|
||||
|
||||
$( singletons
|
||||
[d|
|
||||
data HobbitVertex
|
||||
= TunnelLikeHall
|
||||
| Lonelands
|
||||
| TrollsClearing
|
||||
| Rivendell
|
||||
| MistyMountain
|
||||
| TrollsPath
|
||||
| TrollsCave
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
hobbitTopology :: Topology HobbitVertex
|
||||
hobbitTopology =
|
||||
Topology
|
||||
[ (TunnelLikeHall, [Lonelands])
|
||||
, (Lonelands, [TunnelLikeHall, TrollsClearing])
|
||||
, (TrollsClearing, [Rivendell, TrollsPath])
|
||||
, (Rivendell, [TrollsClearing, MistyMountain])
|
||||
, (MistyMountain, [Rivendell])
|
||||
, (TrollsPath, [TrollsClearing, TrollsCave])
|
||||
, (TrollsCave, [TrollsPath])
|
||||
]
|
||||
|]
|
||||
)
|
||||
|
||||
data KeyState
|
||||
= NoKey
|
||||
| DayDawned
|
||||
| GotKey
|
||||
| DoorUnlocked
|
||||
deriving stock (Eq)
|
||||
|
||||
data HobbitState (vertex :: HobbitVertex) where
|
||||
TunnelLikeHallState :: HobbitState 'TunnelLikeHall
|
||||
LonelandsState :: HobbitState 'Lonelands
|
||||
TrollsClearingState :: KeyState -> HobbitState 'TrollsClearing
|
||||
RivendellState :: KeyState -> HobbitState 'Rivendell
|
||||
MistyMountainState :: KeyState -> HobbitState 'MistyMountain
|
||||
TrollsPathState :: KeyState -> HobbitState 'TrollsPath
|
||||
TrollsCaveState :: HobbitState 'TrollsCave
|
||||
|
||||
stateMessage :: HobbitState vertex -> HobbitMessage
|
||||
stateMessage TunnelLikeHallState =
|
||||
HobbitMessage
|
||||
"You are in a tunnel-like hall.\n\
|
||||
\You can only go east to the Lonelands"
|
||||
stateMessage LonelandsState =
|
||||
HobbitMessage
|
||||
"You are in the lonelands.\n\
|
||||
\You can either go west to a tunnel-like hall\n\
|
||||
\or go east to the Trolls clearing"
|
||||
stateMessage (TrollsClearingState keyState) =
|
||||
if keyState == DayDawned
|
||||
then
|
||||
HobbitMessage
|
||||
"You are in the Trolls clearing.\n\
|
||||
\You could go north to the Trolls path,\n\
|
||||
\you can go east to Rivendell\n\
|
||||
\or you could get the key for the TrollsCave"
|
||||
else
|
||||
HobbitMessage
|
||||
"You are in the Trolls clearing.\n\
|
||||
\You could go north to the Trolls path,\n\
|
||||
\you can go east to Rivendell"
|
||||
stateMessage (RivendellState _) =
|
||||
HobbitMessage
|
||||
"You are in Rivendell.\n\
|
||||
\You could either go west to the Trolls clearing\n\
|
||||
\or go east to the Misty mountains\n"
|
||||
stateMessage (MistyMountainState _) =
|
||||
HobbitMessage
|
||||
"You are in the Misty mountains.\n\
|
||||
\You can only go east to Rivendell"
|
||||
stateMessage (TrollsPathState keyState) =
|
||||
case keyState of
|
||||
NoKey ->
|
||||
HobbitMessage
|
||||
"You are in the Trolls path.\n\
|
||||
\You can go south to the Trolls clearing\n\
|
||||
\or you can wait a bit"
|
||||
DayDawned ->
|
||||
HobbitMessage
|
||||
"You are in the Trolls path.\n\
|
||||
\You can go south to the Trolls clearing\n\
|
||||
\or you can wait some more"
|
||||
GotKey ->
|
||||
HobbitMessage
|
||||
"You are in the Trolls path.\n\
|
||||
\You can go south to the Trolls clearing,\n\
|
||||
\you can unlock the door to the Trolls cave\n\
|
||||
\or you can wait some more"
|
||||
DoorUnlocked ->
|
||||
HobbitMessage
|
||||
"You are in the Trolls path.\n\
|
||||
\You can go south to the Trolls clearing\n\
|
||||
\or you can go north to the Trolls cave"
|
||||
stateMessage TrollsCaveState =
|
||||
HobbitMessage
|
||||
"Welcome to the Trolls cave!\n\
|
||||
\Now you can go back south to the Trolls path"
|
||||
|
||||
hobbitResult
|
||||
:: (Applicative m, AllowedTransition HobbitTopology initialVertex finalVertex)
|
||||
=> HobbitState finalVertex
|
||||
-> ActionResult m HobbitTopology HobbitState initialVertex HobbitMessage
|
||||
hobbitResult hobbitState = pureResult (stateMessage hobbitState) hobbitState
|
||||
|
||||
hobbitMachine :: HobbitState vertex -> BaseMachine HobbitTopology HobbitCommand HobbitMessage
|
||||
hobbitMachine initialState =
|
||||
BaseMachineT
|
||||
{ initialState = InitialState initialState
|
||||
, action = \case
|
||||
TunnelLikeHallState -> \case
|
||||
GoEast -> hobbitResult LonelandsState
|
||||
_ -> hobbitResult TunnelLikeHallState
|
||||
LonelandsState -> \case
|
||||
GoEast -> hobbitResult $ TrollsClearingState NoKey
|
||||
GoWest -> hobbitResult TunnelLikeHallState
|
||||
_ -> hobbitResult LonelandsState
|
||||
TrollsClearingState keyState -> \case
|
||||
GoEast -> hobbitResult $ RivendellState NoKey
|
||||
GoNorth -> hobbitResult $ TrollsPathState keyState
|
||||
GetKey ->
|
||||
if keyState == DayDawned
|
||||
then hobbitResult $ TrollsClearingState GotKey
|
||||
else hobbitResult $ TrollsClearingState keyState
|
||||
_ -> hobbitResult $ TrollsClearingState keyState
|
||||
RivendellState keyState -> \case
|
||||
GoEast -> hobbitResult $ MistyMountainState keyState
|
||||
GoWest -> hobbitResult $ TrollsClearingState keyState
|
||||
_ -> hobbitResult $ RivendellState keyState
|
||||
MistyMountainState keyState -> \case
|
||||
GoWest -> hobbitResult $ RivendellState keyState
|
||||
_ -> hobbitResult $ MistyMountainState keyState
|
||||
TrollsPathState keyState -> \case
|
||||
GoSouth -> hobbitResult $ TrollsClearingState keyState
|
||||
GoNorth ->
|
||||
if keyState == DoorUnlocked
|
||||
then hobbitResult TrollsCaveState
|
||||
else hobbitResult $ TrollsPathState keyState
|
||||
Wait ->
|
||||
if keyState == NoKey
|
||||
then hobbitResult $ TrollsPathState DayDawned
|
||||
else hobbitResult $ TrollsPathState keyState
|
||||
UnlockDoor ->
|
||||
if keyState == GotKey
|
||||
then hobbitResult $ TrollsPathState DoorUnlocked
|
||||
else hobbitResult $ TrollsPathState keyState
|
||||
_ -> hobbitResult (TrollsPathState keyState)
|
||||
TrollsCaveState -> \case
|
||||
GoSouth -> hobbitResult $ TrollsPathState DoorUnlocked
|
||||
_ -> hobbitResult TrollsCaveState
|
||||
}
|
Loading…
Reference in New Issue
Block a user