Uno.hs

{-# 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 #-}
-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wunticked-promoted-constructors
{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
-- 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

import Crem.BaseMachine (InitialState (..))
import Crem.Decider (Decider (..), EvolutionResult (..))
import Crem.Render.RenderableVertices (AllVertices (..), RenderableVertices)
import Crem.Topology
import "singletons-base" Data.Singletons.Base.TH
import Prelude hiding (id, init, reverse)
import Prelude qualified (id)

-- * Domain

newtype PlayerCount = PlayerCount Int
  deriving newtype (Eq, Ord, Show)

data Digit
  = Zero
  | One
  | Two
  | Three
  | Four
  | Five
  | Six
  | Seven
  | Eigth
  | Nine
  deriving stock (Eq, Show)

data Colour
  = Red
  | Green
  | Blue
  | Yellow
  deriving stock (Eq, Show)

data Card
  = DigitCard Digit Colour
  | Skip Colour
  | Kickback Colour
  deriving stock (Eq, Show)

colour :: Card -> Colour
colour (DigitCard _ c) = c
colour (Skip c) = c
colour (Kickback c) = c

sameColour :: Card -> Card -> Bool
sameColour card1 card2 =
  colour card1 == colour card2
data CardValue
  = DigitValue Digit
  | SkipValue
  | KickbackValue
  deriving stock (Eq)

value :: Card -> CardValue
value (DigitCard d _) = DigitValue d
value (Skip _) = SkipValue
value (Kickback _) = KickbackValue

sameValue :: Card -> Card -> Bool
sameValue card1 card2 =
  value card1 == value card2

newtype PlayerId = PlayerId Int
  deriving newtype (Eq, Show)

data Direction
  = Clockwise
  | CounterClockwise

reverseDirection :: Direction -> Direction
reverseDirection Clockwise = CounterClockwise
reverseDirection CounterClockwise = Clockwise

data Player = Player
  { id :: PlayerId
  , count :: PlayerCount
  , direction :: Direction
  }

init :: PlayerId -> PlayerCount -> Player
init playerId count =
  Player
    { id = playerId
    , count = count
    , direction = Clockwise
    }

next :: Player -> Player
next (Player (PlayerId id) (PlayerCount count) direction) =
  case direction of
    Clockwise ->
      Player
        { id = PlayerId $ (id + 1) `mod` count
        , count = PlayerCount count
        , direction
        }
    CounterClockwise ->
      Player
        { id = PlayerId $ (id - 1) `mod` count
        , count = PlayerCount count
        , direction
        }

skip :: Player -> Player
skip = next . next

reverse :: Player -> Player
reverse (Player id count direction) =
  Player id count $ reverseDirection direction

nextPlayer :: Card -> Player -> Player
nextPlayer card player = case card of
  DigitCard _ _ -> next player
  Skip _ -> skip player
  Kickback _ -> next . reverse $ player

set :: PlayerId -> Player -> Player
set playerId player = player {id = playerId}

-- * Commands and events

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
  | CardPlayed PlayData
  | CardPlayedAndTurnBegan PlayData PlayerId
  | WrongCardPlayed PlayData
  | PlayerPlayedAtWrongTurn PlayData
  deriving stock (Eq, Show)

-- * Topology

$( singletons
    [d|
      data UnoVertex
        = Initial
        | Started
        deriving stock (Eq, Show, Enum, Bounded)

      unoTopology :: Topology UnoVertex
      unoTopology = Topology [(Initial, [Started])]
      |]
 )

deriving via AllVertices UnoVertex instance RenderableVertices UnoVertex

-- * State

data StateData = StateData
  { topCard :: Card
  , currentPlayer :: Player
  }

data UnoState (vertex :: UnoVertex) where
  UnoInitialState :: UnoState 'Initial
  UnoStartedState :: StateData -> UnoState 'Started

-- * Errors

data GameError
  = TooFewPlayers
  | GameAlreadyStarted
  | GameNotStarted
  deriving stock (Eq, Show)

-- * Machine

-- | 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
    , decide = \command state ->
        case (state, command) of
          (_, StartGame initialData)
            | players initialData < PlayerCount 2 ->
                Left TooFewPlayers
          (UnoStartedState _, StartGame _) ->
            Left GameAlreadyStarted
          (_, StartGame initialData) ->
            Right $
              GameStarted
                initialData
                ( id $
                    nextPlayer
                      (firstCard initialData)
                      (init (PlayerId 0) $ players initialData)
                )
          (UnoInitialState, PlayCard _) ->
            Left GameNotStarted
          (UnoStartedState stateData, PlayCard playData)
            | id (currentPlayer stateData) /= playerId playData ->
                if sameColour (topCard stateData) (card playData) && sameValue (topCard stateData) (card playData)
                  then Right $ CardPlayed playData
                  else Right $ PlayerPlayedAtWrongTurn playData
          (UnoStartedState stateData, PlayCard playData) ->
            if sameColour (topCard stateData) (card playData) || sameValue (topCard stateData) (card playData)
              then
                Right $
                  CardPlayedAndTurnBegan
                    playData
                    ( id $
                        nextPlayer
                          (card playData)
                          (currentPlayer stateData)
                    )
              else Right $ WrongCardPlayed playData
    , evolve = \state eitherErrorEvent ->
        case eitherErrorEvent of
          Left _ -> EvolutionResult state
          Right event -> case (state, event) of
            (UnoInitialState, GameStarted initialData playerId) ->
              initialResult initialData playerId
            (UnoStartedState _, GameStarted initialData playerId) ->
              initialResult initialData playerId
            (UnoStartedState stateData, CardPlayed playData) ->
              playResult stateData playData Nothing
            (UnoStartedState stateData, CardPlayedAndTurnBegan playData playerId) ->
              playResult stateData playData (Just playerId)
            _ -> EvolutionResult state
    }
  where
    initialResult
      :: AllowedTransition UnoTopology initialVertex 'Started
      => InitialData
      -> PlayerId
      -> EvolutionResult UnoTopology UnoState initialVertex (Either GameError Event)
    initialResult initialData playerId =
      EvolutionResult $
        UnoStartedState $
          StateData
            { topCard = firstCard initialData
            , currentPlayer = init playerId $ players initialData
            }

    playResult
      :: StateData
      -> PlayData
      -> Maybe PlayerId
      -> EvolutionResult UnoTopology UnoState 'Started (Either GameError Event)
    playResult stateData playData maybePlayerId =
      EvolutionResult $
        UnoStartedState $
          StateData
            { topCard = card playData
            , currentPlayer = maybe Prelude.id set maybePlayerId $ currentPlayer stateData
            }