diplomacy-0.1.0.0: Diplomacy/OrderObject.hs

{-|
Module      : Diplomacy.OrderObject
Description : Definition of OrderObject, which describes what a Subject is to do.
Copyright   : (c) Alexander Vieth, 2015
Licence     : BSD3
Maintainer  : aovieth@gmail.com
Stability   : experimental
Portability : non-portable (GHC only)
-}

{-# LANGUAGE AutoDeriveTypeable #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE StandaloneDeriving #-}

module Diplomacy.OrderObject (

    OrderObject(..)
  , orderObjectEqual

  , SomeOrderObject(..)

  , moveTarget
  , supportedSubject
  , supportTarget
  , convoySubject
  , convoyTarget
  , withdrawTarget

  ) where

import Diplomacy.Phase
import Diplomacy.Subject
import Diplomacy.OrderType
import Diplomacy.Province

-- | The objective of an order. Together with an Subject and a GreatPower,
--   this makes a complete order.
data OrderObject (phase :: Phase) (order :: OrderType) where

    MoveObject :: ProvinceTarget -> OrderObject Typical Move
    SupportObject
        :: Subject
        -> ProvinceTarget
        -> OrderObject Typical Support
    ConvoyObject
        -- TODO later, would be cool if we could use type system extensions
        -- to eliminate bogus convoys like convoys of fleets or convoys from/to
        -- water provinces.
        :: Subject
        -> ProvinceTarget
        -> OrderObject Typical Convoy

    WithdrawObject :: ProvinceTarget -> OrderObject Retreat Withdraw
    SurrenderObject :: OrderObject Retreat Surrender

    DisbandObject :: OrderObject Adjust Disband
    BuildObject :: OrderObject Adjust Build
    ContinueObject :: OrderObject Adjust Continue
    -- This is convenient because with it, every unit always has an
    -- order in every phase.

deriving instance Eq (OrderObject phase order)
deriving instance Show (OrderObject phase order)

instance Ord (OrderObject phase order) where
    x `compare` y = case (x, y) of
        (MoveObject pt, MoveObject pt') -> pt `compare` pt'
        (SupportObject subj pt, SupportObject subj' pt') -> (subj, pt) `compare` (subj, pt')
        (ConvoyObject subj pt, ConvoyObject subj' pt') -> (subj, pt) `compare` (subj', pt')
        (SurrenderObject, SurrenderObject) -> EQ
        (WithdrawObject pt, WithdrawObject pt') -> pt `compare` pt'
        (DisbandObject, DisbandObject) -> EQ
        (BuildObject, BuildObject) -> EQ
        (ContinueObject, ContinueObject) -> EQ

orderObjectEqual :: OrderObject phase order -> OrderObject phase' order' -> Bool
orderObjectEqual object1 object2 = case (object1, object2) of
    (MoveObject pt1, MoveObject pt2) -> pt1 == pt2
    (SupportObject subj1 pt1, SupportObject subj2 pt2) -> (subj1, pt1) == (subj2, pt2)
    (ConvoyObject subj1 pt1, ConvoyObject subj2 pt2) -> (subj1, pt1) == (subj2, pt2)
    (WithdrawObject pt1, WithdrawObject pt2) -> pt1 == pt2
    (SurrenderObject, SurrenderObject) -> True
    (DisbandObject, DisbandObject) -> True
    (BuildObject, BuildObject) -> True
    (ContinueObject, ContinueObject) -> True
    _ -> False

moveTarget :: OrderObject Typical Move -> ProvinceTarget
moveTarget (MoveObject x) = x

supportedSubject :: OrderObject Typical Support -> Subject
supportedSubject (SupportObject x _) = x

supportTarget :: OrderObject Typical Support -> ProvinceTarget
supportTarget (SupportObject _ x) = x

convoySubject :: OrderObject Typical Convoy -> Subject
convoySubject (ConvoyObject x _) = x

convoyTarget :: OrderObject Typical Convoy -> ProvinceTarget
convoyTarget (ConvoyObject _ x) = x

withdrawTarget :: OrderObject Retreat Withdraw -> ProvinceTarget
withdrawTarget (WithdrawObject x) = x

data SomeOrderObject phase where
    SomeOrderObject :: OrderObject phase order -> SomeOrderObject phase

deriving instance Show (SomeOrderObject phase)

{-
instance Eq (SomeOrderObject phase) where
    (SomeOrderObject x) == (SomeOrderObject y) = case (x, y) of
        (MoveObject _, MoveObject _) -> x == y
        (SupportObject _ _, SupportObject _ _) -> x == y
        (ConvoyObject _ _, ConvoyObject _ _) -> x == y
        (SurrenderObject, SurrenderObject) -> x == y
        (WithdrawObject _, WithdrawObject _) -> x == y
        (DisbandObject, DisbandObject) -> x == y
        (BuildObject, BuildObject) -> x == y
        (ContinueObject, ContinueObject) -> x == y
-}