generic instance

generic instance

-- | This module provides 32-bit unsigned integers. Provided type `UInt`
-- | is based on the `x >>> 0` trick analogous to how PureScript's `Int`
-- | is based on `x | 0` trick.
-- | The type has range from `0` to `4294967295`.
module Data.UInt
     ( UInt
     , fromInt
     , fromInt'
     , toInt
     , toInt'
     , fromNumber
     , fromNumber'
     , toNumber
     , floor
     , ceil
     , round
     , pow
     , and, (.&.)
     , or, (.|.)
     , xor, (.^.)
     , shl
     , shr
     , zshr
     , complement
     , toString
     , fromString
     ) where

import Data.Maybe (Maybe(..))
import Data.Semiring (class Semiring)
import Data.Ring (class Ring, negate)
import Data.CommutativeRing (class CommutativeRing)
import Data.EuclideanRing (class EuclideanRing, mod)
import Data.Eq (class Eq, (==))
import Data.Ord (class Ord, Ordering(..), clamp)
import Data.Bounded (class Bounded, top, bottom)
import Data.Show (class Show)
import Data.Function ((<<<))
import Data.Semigroup ((<>))
import Math as Math

import Data.Generic.Rep (class Generic, Constructor (..), Argument (..))

foreign import data UInt :: Type

foreign import exact :: forall a b. (b -> Maybe b) -> Maybe b -> (a -> b) -> a -> Maybe b
foreign import from :: forall a. a -> UInt

instance genericUInt :: Generic UInt (Constructor "UInt" (Argument Number)) where
  from x = Constructor (Argument (toNumber x))
  to (Constructor (Argument x)) = fromNumber x

-- | Cast an `Int` to an `UInt` turning negative `Int`s into `UInt`s
-- | in range from `2^31` to `2^32-1`.
-- |
-- |     > fromInt 123
-- |     123u
-- |
-- |     > fromInt (-123)
-- |     4294967173u
fromInt :: Int -> UInt
fromInt = from

-- | Converts positive `Int`s into `UInt`. Returns `Nothing` for
-- | negative `Int`s
-- |
-- |     > fromInt' 123
-- |     (Just 123u)
-- |
-- |     > fromInt' (-123)
-- |     Nothing
fromInt' :: Int -> Maybe UInt
fromInt' = exact Just Nothing fromInt

-- | Cast an `UInt` to an `Int` turning `UInt`s in range from `2^31`
-- | to `2^32-1` into negative `Int`s.
-- |
-- |     > toInt (fromInt 123)
-- |     123
-- |
-- |     > toInt (fromInt (-1))
-- |     -1
foreign import toInt :: UInt -> Int

-- | Converts `UInt`s in range from `0` to `2^31-1` into `Int`s. Rreturns
-- | `Nothing` for `UInt`'s in range from `2^31` to `2^32-1`.
-- |
-- |     > toInt' (fromInt 123)
-- |     (Just 123)
-- |
-- |     > toInt' (fromInt (-1))
-- |     Nothing
toInt' :: UInt -> Maybe Int
toInt' = exact Just Nothing toInt

foreign import uintAdd :: UInt -> UInt -> UInt
foreign import uintMul :: UInt -> UInt -> UInt

instance uintSemiring :: Semiring UInt where
  zero = fromInt 0
  add = uintAdd
  one = fromInt 1
  mul = uintMul

foreign import uintSub :: UInt -> UInt -> UInt

instance uintRing :: Ring UInt where
  sub = uintSub

instance uintCommutativeRing :: CommutativeRing UInt

foreign import uintDiv :: UInt -> UInt -> UInt
foreign import uintMod :: UInt -> UInt -> UInt
foreign import uintDegree :: UInt -> Int

instance uintEuclideanRing :: EuclideanRing UInt where
  div = uintDiv
  mod = uintMod
  degree = uintDegree

foreign import uintEq :: UInt -> UInt -> Boolean

instance uintEqInstance :: Eq UInt where
  eq = uintEq

foreign import uintCmp :: Ordering -> Ordering -> Ordering -> UInt -> UInt -> Ordering

instance uintOrd :: Ord UInt where
  compare = uintCmp LT EQ GT

foreign import fromStringImpl :: String -> Number

-- | Tries to parse an `UInt` from a `String`.
fromString :: String -> Maybe UInt
fromString = fromNumber' <<< fromStringImpl

-- | Converts an `UInt` to a `String`.
-- |
-- | There is also a `Show` instance (so you can use `show`), but that
-- | appends `u` suffix, which isn't always what you'll want.
-- |
-- |      toString (fromInt 42) == "42"
-- |      show (fromInt 42) == "42u"
foreign import toString :: UInt -> String

instance uintShowInstance :: Show UInt where
  show u = toString u <> "u"

instance uintBounded :: Bounded UInt where
  bottom = fromInt 0
  top = fromInt (-1)

-- | Cast a `Number` `n` to `UInt` by performing 0-bit unsigned right
-- | shift `n >>> 0`.
fromNumber :: Number -> UInt
fromNumber = from

-- | Convert a `Number` which is already an `UInt` to `UInt`. Fails
-- | for non-integers and integers not in range from `0` to `2^32-1`.
fromNumber' :: Number -> Maybe UInt
fromNumber' = exact Just Nothing fromNumber

-- | Cast an `UInt` to a `Number`, which is always safe to do.
foreign import toNumber :: UInt -> Number

clamp' :: Number -> Number
clamp' = clamp (toNumber bottom) (toNumber top)

-- | Convert a `Number` to an `UInt`. Takes the closest integer equal to or
-- | less than the argument. Values outside the `UInt` range are clamped.
-- |
-- |     > floor 27.1
-- |     27u
-- |
-- |     > floor 27.9
-- |     27u
-- |
-- |     > floor (-27.1)
-- |     0u
-- |
-- |     > floor (1.0e65)
-- |     4294967295u
-- |
-- |     > floor (-1.0e65)
-- |     0u
floor :: Number -> UInt
floor = fromNumber <<< Math.floor <<< clamp'

-- | Convert a `Number` to an `UInt`. Takes the closest integer equal to or
-- | greater than the argument. Values outside the `UInt` range are clamped.
-- |
-- |     > ceil 27.1
-- |     28u
-- |
-- |     > ceil 27.9
-- |     28u
-- |
-- |     > ceil (-27.1)
-- |     0u
-- |
-- |     > ceil (1.0e65)
-- |     4294967295u
-- |
-- |     > ceil (-1.0e65)
-- |     0u
ceil :: Number -> UInt
ceil = fromNumber <<< Math.ceil <<< clamp'

-- | Convert a `Number` to an `UInt`, by taking the nearest integer to the
-- | argument. Values outside the `UInt` range are clamped.
-- |
-- |     > round 27.1
-- |     27u
-- |
-- |     > round 27.9
-- |     28u
-- |
-- |     > round (-27.1)
-- |     0u
-- |
-- |     > round (-27.9)
-- |     0u
-- |
-- |     > round (1.0e65)
-- |     4294967295u
-- |
-- |     > round (-1.0e65)
-- |     0u
round :: Number -> UInt
round = fromNumber <<< Math.round <<< clamp'

-- | Returns whether an `Int53` is an even number.
-- |
-- |     > even (fromInt 0)
-- |     true
-- |
-- |     > even (fromInt 1)
-- |     false
even :: UInt -> Boolean
even u = u `mod` (fromInt 2) == (fromInt 0)

-- | Returns whether an `Int53` is an odd number.
-- |
-- |     > odd (fromInt 0)
-- |     false
-- |
-- |     > odd (fromInt 1)
-- |     true
odd :: UInt -> Boolean
odd u = u `mod` (fromInt 2) == (fromInt 1)

-- | Raises the first argument to the power of the second argument (the exponent).
-- |
-- |     > pow (fromInt 2) (fromInt 3)
-- |     8u
foreign import pow :: UInt -> UInt -> UInt

-- | Bitwise AND.
-- |
-- |     > and (fromInt 6) (fromInt 4)
-- |     4u
foreign import and :: UInt -> UInt -> UInt

infixl 10 and as .&.

-- | Bitwise OR.
-- |
-- |     > or (fromInt 4) (fromInt 2)
-- |     6u
foreign import or :: UInt -> UInt -> UInt

infixl 10 or as .|.

-- | Bitwise XOR.
-- |
-- |     > xor (fromInt 6) (fromInt 4)
-- |     0u
foreign import xor :: UInt -> UInt -> UInt

infixl 10 xor as .^.

-- | Bitwise shift left.
-- |
-- |     > shl (fromInt 4) (fromInt 1)
-- |     8u
foreign import shl :: UInt -> UInt -> UInt

-- | Bitwise shift right while preserving sign.
-- |
-- |     > shr (fromInt 4) (fromInt 1)
-- |     2u
foreign import shr :: UInt -> UInt -> UInt

-- | Bitwise zero-fill shift right.
-- |
-- |     > shr (fromInt 4) (fromInt 1)
-- |     2u
foreign import zshr :: UInt -> UInt -> UInt

-- | Bitwise NOT.
-- |
-- |     > complement (fromInt 0xFF...)
-- |     0u
foreign import complement :: UInt -> UInt

-- | This module provides 32-bit unsigned integers. Provided type `UInt`
-- | is based on the `x >>> 0` trick analogous to how PureScript's `Int`
-- | is based on `x | 0` trick.
-- | The type has range from `0` to `4294967295`.
module Data.UInt
     ( UInt
     , fromInt
     , fromInt'
     , toInt
     , toInt'
     , fromNumber
     , fromNumber'
     , toNumber
     , floor
     , ceil
     , round
     , pow
     , and, (.&.)
     , or, (.|.)
     , xor, (.^.)
     , shl
     , shr
     , zshr
     , complement
     , toString
     , fromString
     ) where

import Data.Maybe (Maybe(..))
import Data.Semiring (class Semiring)
import Data.Ring (class Ring, negate)
import Data.CommutativeRing (class CommutativeRing)
import Data.EuclideanRing (class EuclideanRing, mod)
import Data.Eq (class Eq, (==))
import Data.Ord (class Ord, Ordering(..), clamp)
import Data.Bounded (class Bounded, top, bottom)
import Data.Show (class Show)
import Data.Function ((<<<))
import Data.Semigroup ((<>))
import Math as Math

foreign import data UInt :: Type

foreign import exact :: forall a b. (b -> Maybe b) -> Maybe b -> (a -> b) -> a -> Maybe b
foreign import from :: forall a. a -> UInt

-- | Cast an `Int` to an `UInt` turning negative `Int`s into `UInt`s
-- | in range from `2^31` to `2^32-1`.
-- |
-- |     > fromInt 123
-- |     123u
-- |
-- |     > fromInt (-123)
-- |     4294967173u
fromInt :: Int -> UInt
fromInt = from

-- | Converts positive `Int`s into `UInt`. Returns `Nothing` for
-- | negative `Int`s
-- |
-- |     > fromInt' 123
-- |     (Just 123u)
-- |
-- |     > fromInt' (-123)
-- |     Nothing
fromInt' :: Int -> Maybe UInt
fromInt' = exact Just Nothing fromInt

-- | Cast an `UInt` to an `Int` turning `UInt`s in range from `2^31`
-- | to `2^32-1` into negative `Int`s.
-- |
-- |     > toInt (fromInt 123)
-- |     123
-- |
-- |     > toInt (fromInt (-1))
-- |     -1
foreign import toInt :: UInt -> Int

-- | Converts `UInt`s in range from `0` to `2^31-1` into `Int`s. Rreturns
-- | `Nothing` for `UInt`'s in range from `2^31` to `2^32-1`.
-- |
-- |     > toInt' (fromInt 123)
-- |     (Just 123)
-- |
-- |     > toInt' (fromInt (-1))
-- |     Nothing
toInt' :: UInt -> Maybe Int
toInt' = exact Just Nothing toInt

foreign import uintAdd :: UInt -> UInt -> UInt
foreign import uintMul :: UInt -> UInt -> UInt

instance uintSemiring :: Semiring UInt where
  zero = fromInt 0
  add = uintAdd
  one = fromInt 1
  mul = uintMul

foreign import uintSub :: UInt -> UInt -> UInt

instance uintRing :: Ring UInt where
  sub = uintSub

instance uintCommutativeRing :: CommutativeRing UInt

foreign import uintDiv :: UInt -> UInt -> UInt
foreign import uintMod :: UInt -> UInt -> UInt
foreign import uintDegree :: UInt -> Int

instance uintEuclideanRing :: EuclideanRing UInt where
  div = uintDiv
  mod = uintMod
  degree = uintDegree

foreign import uintEq :: UInt -> UInt -> Boolean

instance uintEqInstance :: Eq UInt where
  eq = uintEq

foreign import uintCmp :: Ordering -> Ordering -> Ordering -> UInt -> UInt -> Ordering

instance uintOrd :: Ord UInt where
  compare = uintCmp LT EQ GT

foreign import fromStringImpl :: String -> Number

-- | Tries to parse an `UInt` from a `String`.
fromString :: String -> Maybe UInt
fromString = fromNumber' <<< fromStringImpl

-- | Converts an `UInt` to a `String`.
-- |
-- | There is also a `Show` instance (so you can use `show`), but that
-- | appends `u` suffix, which isn't always what you'll want.
-- |
-- |      toString (fromInt 42) == "42"
-- |      show (fromInt 42) == "42u"
foreign import toString :: UInt -> String

instance uintShowInstance :: Show UInt where
  show u = toString u <> "u"

instance uintBounded :: Bounded UInt where
  bottom = fromInt 0
  top = fromInt (-1)

-- | Cast a `Number` `n` to `UInt` by performing 0-bit unsigned right
-- | shift `n >>> 0`.
fromNumber :: Number -> UInt
fromNumber = from

-- | Convert a `Number` which is already an `UInt` to `UInt`. Fails
-- | for non-integers and integers not in range from `0` to `2^32-1`.
fromNumber' :: Number -> Maybe UInt
fromNumber' = exact Just Nothing fromNumber

-- | Cast an `UInt` to a `Number`, which is always safe to do.
foreign import toNumber :: UInt -> Number

clamp' :: Number -> Number
clamp' = clamp (toNumber bottom) (toNumber top)

-- | Convert a `Number` to an `UInt`. Takes the closest integer equal to or
-- | less than the argument. Values outside the `UInt` range are clamped.
-- |
-- |     > floor 27.1
-- |     27u
-- |
-- |     > floor 27.9
-- |     27u
-- |
-- |     > floor (-27.1)
-- |     0u
-- |
-- |     > floor (1.0e65)
-- |     4294967295u
-- |
-- |     > floor (-1.0e65)
-- |     0u
floor :: Number -> UInt
floor = fromNumber <<< Math.floor <<< clamp'

-- | Convert a `Number` to an `UInt`. Takes the closest integer equal to or
-- | greater than the argument. Values outside the `UInt` range are clamped.
-- |
-- |     > ceil 27.1
-- |     28u
-- |
-- |     > ceil 27.9
-- |     28u
-- |
-- |     > ceil (-27.1)
-- |     0u
-- |
-- |     > ceil (1.0e65)
-- |     4294967295u
-- |
-- |     > ceil (-1.0e65)
-- |     0u
ceil :: Number -> UInt
ceil = fromNumber <<< Math.ceil <<< clamp'

-- | Convert a `Number` to an `UInt`, by taking the nearest integer to the
-- | argument. Values outside the `UInt` range are clamped.
-- |
-- |     > round 27.1
-- |     27u
-- |
-- |     > round 27.9
-- |     28u
-- |
-- |     > round (-27.1)
-- |     0u
-- |
-- |     > round (-27.9)
-- |     0u
-- |
-- |     > round (1.0e65)
-- |     4294967295u
-- |
-- |     > round (-1.0e65)
-- |     0u
round :: Number -> UInt
round = fromNumber <<< Math.round <<< clamp'

-- | Returns whether an `Int53` is an even number.
-- |
-- |     > even (fromInt 0)
-- |     true
-- |
-- |     > even (fromInt 1)
-- |     false
even :: UInt -> Boolean
even u = u `mod` (fromInt 2) == (fromInt 0)

-- | Returns whether an `Int53` is an odd number.
-- |
-- |     > odd (fromInt 0)
-- |     false
-- |
-- |     > odd (fromInt 1)
-- |     true
odd :: UInt -> Boolean
odd u = u `mod` (fromInt 2) == (fromInt 1)

-- | Raises the first argument to the power of the second argument (the exponent).
-- |
-- |     > pow (fromInt 2) (fromInt 3)
-- |     8u
foreign import pow :: UInt -> UInt -> UInt

-- | Bitwise AND.
-- |
-- |     > and (fromInt 6) (fromInt 4)
-- |     4u
foreign import and :: UInt -> UInt -> UInt

infixl 10 and as .&.

-- | Bitwise OR.
-- |
-- |     > or (fromInt 4) (fromInt 2)
-- |     6u
foreign import or :: UInt -> UInt -> UInt

infixl 10 or as .|.

-- | Bitwise XOR.
-- |
-- |     > xor (fromInt 6) (fromInt 4)
-- |     0u
foreign import xor :: UInt -> UInt -> UInt

infixl 10 xor as .^.

-- | Bitwise shift left.
-- |
-- |     > shl (fromInt 4) (fromInt 1)
-- |     8u
foreign import shl :: UInt -> UInt -> UInt

-- | Bitwise shift right while preserving sign.
-- |
-- |     > shr (fromInt 4) (fromInt 1)
-- |     2u
foreign import shr :: UInt -> UInt -> UInt

-- | Bitwise zero-fill shift right.
-- |
-- |     > shr (fromInt 4) (fromInt 1)
-- |     2u
foreign import zshr :: UInt -> UInt -> UInt

-- | Bitwise NOT.
-- |
-- |     > complement (fromInt 0xFF...)
-- |     0u
foreign import complement :: UInt -> UInt


Add documentation to DSL functions

Add documentation to DSL functions

module Test.Spec (
  Name(..),
  Result(..),
  Group(..),
  Spec(..),
  describe,
  pending,
  it,
  collect
  ) where

import Prelude

import Control.Monad.Aff           (Aff())
import Control.Monad.Eff.Exception (Error())
import Control.Monad.State         (State(), modify, runState)
import Data.Tuple                  (snd)

type Name = String

data Group t
  = Describe Name (Array (Group t))
  | It Name t
  | Pending Name

data Result
  = Success
  | Failure Error

instance showResult :: Show Result where
  show Success = "Success"
  show (Failure err) = "Failure (Error ...)"

instance eqResult :: Eq Result where
  eq Success Success = true
  eq (Failure _) (Failure _) = true
  eq _ _ = false

instance showGroup :: Show t => Show (Group t) where
  show (Describe name groups) = "Describe " <> show name <> " " <> show groups
  show (It name test) = "It " <> show name <> " " <> show test
  show (Pending name) = "Describe " <> show name

instance eqGroup :: Eq t => Eq (Group t) where
  eq (Describe n1 g1) (Describe n2 g2) = n1 == n2 && g1 == g2
  eq (It n1 t1)       (It n2 t2)       = n1 == n2 && t1 == t2
  eq (Pending n1)     (Pending n2)     = n1 == n2
  eq _                _                = false

-- Specifications with unevaluated tests.
type Spec r t = State (Array (Group (Aff r Unit))) t

collect :: forall r. Spec r Unit
        -> Array (Group (Aff r Unit))
collect r = snd $ runState r []

---------------------
--       DSL       --
---------------------

-- | Combine a group of specs into a described hierarchy.
describe :: forall r. String
         -> Spec r Unit
         -> Spec r Unit
describe name its = do
  modify $ \r -> r <> [Describe name (collect its)]
  pure unit

-- | Create a pending spec.
pending :: forall r. String
        -> Spec r Unit
pending name = modify $ \p -> p <> [Pending name]

-- | Create a pending spec with a body that is ignored by
-- | the runner. It can be useful for documenting what the
-- | spec should test when non-pending.
pending' :: forall r. String
        -> Aff r Unit
        -> Spec r Unit
pending' name _ = pending name

-- | Create a spec with a description.
it :: forall r. String
   -> Aff r Unit
   -> Spec r Unit
it description tests =
  do
    modify $ \p -> p <> [It description tests]
    pure unit

module Test.Spec (
  Name(..),
  Result(..),
  Group(..),
  Spec(..),
  describe,
  pending,
  it,
  collect
  ) where

import Prelude

import Control.Monad.Aff           (Aff())
import Control.Monad.Eff.Exception (Error())
import Control.Monad.State         (State(), modify, runState)
import Data.Tuple                  (snd)

type Name = String

data Group t
  = Describe Name (Array (Group t))
  | It Name t
  | Pending Name

data Result
  = Success
  | Failure Error

instance showResult :: Show Result where
  show Success = "Success"
  show (Failure err) = "Failure (Error ...)"

instance eqResult :: Eq Result where
  eq Success Success = true
  eq (Failure _) (Failure _) = true
  eq _ _ = false

instance showGroup :: Show t => Show (Group t) where
  show (Describe name groups) = "Describe " <> show name <> " " <> show groups
  show (It name test) = "It " <> show name <> " " <> show test
  show (Pending name) = "Describe " <> show name

instance eqGroup :: Eq t => Eq (Group t) where
  eq (Describe n1 g1) (Describe n2 g2) = n1 == n2 && g1 == g2
  eq (It n1 t1)       (It n2 t2)       = n1 == n2 && t1 == t2
  eq (Pending n1)     (Pending n2)     = n1 == n2
  eq _                _                = false

-- Specifications with unevaluated tests.
type Spec r t = State (Array (Group (Aff r Unit))) t

collect :: forall r. Spec r Unit
        -> Array (Group (Aff r Unit))
collect r = snd $ runState r []

---------------------
--       DSL       --
---------------------

describe :: forall r. String
         -> Spec r Unit
         -> Spec r Unit
describe name its = do
  modify $ \r -> r <> [Describe name (collect its)]
  pure unit

pending :: forall r. String
        -> Spec r Unit
pending name = modify $ \p -> p <> [Pending name]

it :: forall r. String
   -> Aff r Unit
   -> Spec r Unit
it description tests =
  do
    modify $ \p -> p <> [It description tests]
    pure unit


some cleanup

some cleanup

{- | This module implements `DamageVector`:
   | an array of `Damage`s that can be applied to one fleet of `Ship`s.
   | most functions prefixed with `calc` in this module
   | produces either `LR DamageVector` or a single `DamageVector`.
   | which can then be converted `NormalDamageVector` or `CombinedDamageVector`
   | depending on what the corresponding data is standing for.
 -}
module KanColle.DamageAnalysis.DamageVector
  ( DamageVector, getDV, mkDV

  , NormalDamageVector
  , GCombinedDamageVector
  , CombinedDamageVector, CombinedDamageVectorAC
  , FleetRole(..)

  , calcKoukuDamage
  , calcKoukuDamageAC
  , calcKoukuDamageCombined
  , calcSupportAirAttackDamage
  , calcSupportAirAttackDamageAC
  , calcSupportHouraiDamage
  , calcSupportHouraiDamageAC
  , calcHougekiDamage
  , calcRaigekiDamage

  , calcRaigekiDamageAC
  , calcHougekiDamageAC

  , calcLandBasedKoukuDamage

  , toGCombined
  , toCombined
  , toCombinedAC

  , applyDamageVector
  , applyNormalDamageVector
  , applyCombinedDamageVector
  ) where

import Prelude
import Data.Monoid
import Data.Int as Int
import Data.Array as A
import Data.Array.ST as STA
import Data.Unfoldable hiding (fromMaybe)
import Control.Monad.Eff
import Control.Monad.ST as ST
import KanColle.Util
import KanColle.DamageAnalysis.Types
import KanColle.DamageAnalysis.Damage

import Data.Foreign
import Data.Foldable
import KanColle.KCAPI.Battle
import Data.Maybe
import Data.String (joinWith)

-- when flagship protection happens
-- and extra 0.1 will be added to that value
-- for our purpose we don't need to deal with that
-- so all damages can be normalized as Ints
normalizeDamage :: Number -> Int
normalizeDamage x
  | x >= 0.0 = Int.floor x
  | x == (-1.0) = 0
  | otherwise =
    let warning = "invalid damage number: " <> show x
    in traceWarn warning (\_ -> 0)

-- | `DamageVector` is a 6-element array of `Damage`s
newtype DamageVector = DV (Array Damage)

-- | fetches the array inside `DamageVector`
getDV :: DamageVector -> Array Damage
getDV (DV v) = v

-- | creates `DamageVector` from arrays.
-- | array has to be of length 6
mkDV :: Array Damage -> DamageVector
mkDV xs = if check
    then DV xs
    else throwWith "mkDV: array size should be 6"
  where
    check = A.length xs == 6

instance semigroupDamageVector :: Semigroup DamageVector where
  append (DV a) (DV b) = DV (A.zipWith (<>) a b)

instance monoidDamageVector :: Monoid DamageVector where
  mempty = DV (replicate 6 mempty)

-- | `DamageVector` for normal battles
type NormalDamageVector = NormalBattle DamageVector

-- | `DamageVector` for battles involving comined fleets
type GCombinedDamageVector = GCombinedBattle DamageVector
type CombinedDamageVector = CombinedBattle DamageVector
type CombinedDamageVectorAC = CombinedBattleAC DamageVector

debugShowDV :: DamageVector -> String
debugShowDV (DV xs) = joinWith "," (map (show <<< damageToInt) xs)

-- TODO: abandon this and always use the safe version
-- | get `DamageVector` from raw `fDam` and `eDam` fields
fromFDamAndEDam :: KoukuStage3 -> LR DamageVector
fromFDamAndEDam ks3 =
    { left: DV (convertFEDam fDam)
    , right: DV (convertFEDam eDam) }
  where
    fDam = fromMaybe mempty (getKoukuStage3FDam ks3)
    eDam = fromMaybe mempty (getKoukuStage3EDam ks3)

-- L: ally fleet, LL: ally main, LR: ally escort
-- R: enemy fleet: RL: enemy main, RR: enemy escort
fromFDamAndEDamAC :: forall a.
                  { api_fdam :: Array Number
                  , api_edam :: Array Number | a} -> LR (LR DamageVector)
fromFDamAndEDamAC v = (lrMap >>> lrMap) DV
    { left: allyDams
    , right: enemyDams }
  where
    longFDam = convertFEDam v.api_fdam
    allyDams = fleetSplit false longFDam

    longEDam = convertFEDam v.api_edam
    enemyDams = fleetSplit false longEDam

-- (internal use only)
-- an "-1" is put in front of both api_fdam and api_edam
-- we first drop that element and then convert
-- integers intos Damages
convertFEDam :: Array Number -> Array Damage
convertFEDam = unsafeArrTail >>> map (normalizeDamage >>> mkDamage)

-- | calculate damage from kouku (aerial) stages
calcKoukuDamage :: Kouku -> LR DamageVector
calcKoukuDamage kk = fromFDamAndEDam kk.api_stage3

-- calcKoukuDamageAC :: Kouku -> LR DamageVector
-- calcKoukuDamageAC kk = fromFDamAndEDam kk.api_stage3_combined

-- | calculate damage from ally vs. enemy main fleet kouku stages (for Abyssal Combined fleet)
calcKoukuDamageACEMain :: forall a . {api_stage3 :: KoukuStage3 | a} -> LR DamageVector
calcKoukuDamageACEMain kk = fromFDamAndEDam kk.api_stage3

-- | calculate damage from ally vs. enemy escort fleet kouku stages (for Abyssal Combined fleet)
calcKoukuDamageACEEscort :: forall a. {api_stage3_combined :: KoukuStage3 | a} -> LR DamageVector
calcKoukuDamageACEEscort kk = fromFDamAndEDam kk.api_stage3_combined

calcKoukuDamageAC :: forall a.
                  { api_stage3 :: KoukuStage3
                  , api_stage3_combined :: KoukuStage3
                  | a} -> LR (LR DamageVector)
calcKoukuDamageAC kk =
    { left:
      { left: resultEMain.left <> resultEEscort.left
      , right: mempty }
    , right:
      { left: resultEMain.right
      , right: resultEEscort.right } }
  where
    resultEMain = calcKoukuDamageACEMain kk
    resultEEscort = calcKoukuDamageACEEscort kk

-- | calculate damage from kouku (aerial) stages (combined fleet)
-- | note that only escort fleet is taking damage. so we just need DamageVector
calcKoukuDamageCombined :: Kouku -> DamageVector
calcKoukuDamageCombined kk = DV (convertFEDam (kk.api_stage3_combined.api_fdam))

-- | calculate land based kouku damages. whose api_stage3 only have an api_edam field
-- | (because only enemies are taking damage)
calcLandBasedKoukuDamage :: Kouku -> DamageVector
calcLandBasedKoukuDamage lbkk = case getKoukuStage3 lbkk  of
    Just stage3 -> DV (convertFEDam stage3.api_edam)
    Nothing -> mempty

-- | calculate damage from raigeki (torpedo) stages
calcRaigekiDamage :: Raigeki -> LR DamageVector
calcRaigekiDamage = fromFDamAndEDam

calcRaigekiDamageAC :: Raigeki -> LR (LR DamageVector)
calcRaigekiDamageAC = fromFDamAndEDamAC

-- | calculate damage from hougeki (shelling) stages
calcHougekiDamage :: Hougeki -> LR DamageVector
calcHougekiDamage h =
    if lengthCheck
      then let resultArr = runPure (STA.runSTArray resultDV)
           in lrMap DV (fleetSplit false resultArr)
      else throwWith "invalid: api_df_list and api_damage length mismatch"
  where
    cAI :: Foreign -> Array Int
    cAI = unsafeFromForeign
    cAN :: Foreign -> Array Number
    cAN = unsafeFromForeign

    lengthCheck = A.length eventTargets == A.length eventDamages

    eventTargets :: Array Int
    eventTargets = map (cAI >>> toOne) (unsafeArrTail h.api_df_list)
      where
        -- merge targets like [a,a] into a-1 (so that it's zero-indexed)
        -- there are 2 checks:
        --   elements of api_df_list should:
        --   * be non-empty
        --   * all elements of it should be the same
        -- the reason for minus 1 in the end is to make it zero-based
        toOne :: Array Int -> Int
        toOne xs = case A.uncons xs of
          Just {head: y, tail: ys} ->
            if all (\v -> v == y) ys || all (\v -> v == -1) ys
              then y - 1
              else throwWith "invalid: elements are different in api_df_list"
          Nothing -> throwWith "invalid: empty api_df_list element"

    eventDamages :: Array Damage
    eventDamages = map (cAN >>> convert) (unsafeArrTail h.api_damage)
      where
        convert :: Array Number -> Damage
        convert xs = mkDamage totalDmg
          where
            -- there are double attacks in the damage list
            -- because damecon triggers *AFTER* the attack actions are completed
            -- we need to sum damage values before turning it into real Damage
            totalDmg = sum (map normalizeDamage xs :: Array Int)

    accumulateDamage :: forall h r.
                        STA.STArray h Damage -- array reference
                     -> Int -> Damage -- target index and corresponding damage
                     -> Eff (st :: ST.ST h | r) Unit
    accumulateDamage arr targetInd damage = do
        dmg <- peekSTArrayUnsafe arr targetInd
        pokeSTArrayUnsafe arr targetInd (dmg <> damage :: Damage)
        pure unit
    resultDV :: forall h r . Eff (st :: ST.ST h | r) (STA.STArray h Damage)
    resultDV = do
        arr <- STA.thaw (replicate 12 mempty)
        A.zipWithA (accumulateDamage arr) eventTargets eventDamages
        pure arr

calcHougekiDamageAC :: Hougeki -> LR (LR DamageVector)
calcHougekiDamageAC h =
    if lengthCheck
      then let resultArr = runPure (STA.runSTArray resultDV)
           in { left:
                { left: DV (A.slice 0 6 resultArr)
                , right: DV (A.slice 6 12 resultArr) }
              , right:
                { left: DV (A.slice 12 18 resultArr)
                , right: DV (A.slice 18 24 resultArr) }
              }
      else throwWith "invalid: api_df_list / api_damage / api_at_eflag length mismatch"
  where
    cAI :: Foreign -> Array Int
    cAI = unsafeFromForeign
    cAN :: Foreign -> Array Number
    cAN = unsafeFromForeign

    dfList = unsafeArrTail h.api_df_list
    atEFlag :: Array Int
    atEFlag = unsafeArrTail h.api_at_eflag
    damageList = unsafeArrTail h.api_damage

    lengthCheck = A.length dfList == A.length atEFlag
               && A.length dfList == A.length damageList

    eventTargetsRaw :: Array Int
    eventTargetsRaw = map (cAI >>> toOne) (unsafeArrTail h.api_df_list)
      where
        -- merge targets like [a,a] into a-1 (so that it's zero-indexed)
        -- there are 2 checks:
        --   elements of api_df_list should:
        --   * be non-empty
        --   * all elements of it should be the same
        -- the reason for minus 1 in the end is to make it zero-based
        toOne :: Array Int -> Int
        toOne xs = case A.uncons xs of
          Just {head: y, tail: ys} ->
            if all (\v -> v == y) ys || all (\v -> v == -1) ys
              then y - 1
              else throwWith "invalid: elements are different in api_df_list"
          Nothing -> throwWith "invalid: empty api_df_list element"

    eventTargets :: Array Int
    eventTargets = A.zipWith updateTarget eventTargetsRaw atEFlag
      where
        updateTarget rawTarget eFlag = case eFlag of
            -- ally attacks in this turn, so the target is an enemy
            0 -> rawTarget + 12
            -- enemy attacks in this turn, so the target is an ally
            -- nothing to be doing in this case
            1 -> rawTarget
            _ -> throwWith "invalid api_at_eflag element"

    eventDamages :: Array Damage
    eventDamages = map (cAN >>> convert) (unsafeArrTail h.api_damage)
      where
        convert :: Array Number -> Damage
        convert xs = mkDamage totalDmg
          where
            -- there are double attacks in the damage list
            -- because damecon triggers *AFTER* the attack actions are completed
            -- we need to sum damage values before turning it into real Damage
            totalDmg = sum (map normalizeDamage xs :: Array Int)
    accumulateDamage :: forall h r.
                        STA.STArray h Damage -- array reference
                     -> Int -> Damage -- target index and corresponding damage
                     -> Eff (st :: ST.ST h | r) Unit
    accumulateDamage arr targetInd damage = do
        dmg <- peekSTArrayUnsafe arr targetInd
        pokeSTArrayUnsafe arr targetInd (dmg <> damage :: Damage)
        pure unit
    resultDV :: forall h r . Eff (st :: ST.ST h | r) (STA.STArray h Damage)
    resultDV = do
        arr <- STA.thaw (replicate 24 mempty)
        A.zipWithA (accumulateDamage arr) eventTargets eventDamages
        pure arr

-- | calculate damage from support airstrike stages.
-- | note that only enemy is taking damage so this results in
-- | a single `DamageVector`.
calcSupportAirAttackDamage :: SupportAirInfo -> DamageVector
calcSupportAirAttackDamage info = DV $ convertFEDam info.api_stage3.api_edam

calcSupportAirAttackDamageAC :: SupportAirInfo -> LR (LR DamageVector)
calcSupportAirAttackDamageAC info = calcKoukuDamageAC info

-- | calculate damage from support shelling stages.
-- | note that only enemy is taking damage so this results in
-- | a single `DamageVector`.
calcSupportHouraiDamage :: SupportHouraiInfo -> DamageVector
calcSupportHouraiDamage info = DV $ convertFEDam info.api_damage

-- TODO: to be verified, for now I just guess it's an array of raw length 1+12
calcSupportHouraiDamageAC :: SupportHouraiInfo -> LR (LR DamageVector)
calcSupportHouraiDamageAC info = { left: memptyLR, right: lrMap mkDV converted }
  where
    converted = fleetSplit false (convertFEDam info.api_damage)

-- | ally fleet's role in this battle
data FleetRole
  = FRMain -- ally main vs. enemy main
  | FREscort -- ally escort vs. enemy main
  | FRSupport -- ally support exped vs. enemy main
  | FRLandBased -- ally LBAS vs. enemy main
--  | FRMainEEscort -- ally main vs. enemy escort
--  | FRLandBasedEEscort -- ally LBAS vs. enemy escort

-- | `toCombined role dv` converts a `LR DamageVector` whose left part
-- | is playing role `role` into `CombinedDamageVector`
toGCombined :: FleetRole -> LR DamageVector -> GCombinedDamageVector
toGCombined r dv = case r of
    FRMain      ->
        { allyMain: dv.left, allyEscort: mempty
        , enemyMain: dv.right, enemyEscort: mempty }
    FREscort    ->
        { allyMain: mempty, allyEscort: dv.left
        , enemyMain: dv.right, enemyEscort: mempty }
    FRSupport   ->
        { allyMain: mempty, allyEscort: mempty
        , enemyMain: dv.right, enemyEscort: mempty }
    FRLandBased ->
        { allyMain: mempty, allyEscort: mempty
        , enemyMain: dv.right, enemyEscort: mempty }

toCombined :: FleetRole -> LR DamageVector -> CombinedDamageVector
toCombined r dv = toCombinedBattle (toGCombined r dv)

-- TODO: add check on dv.left.right, which should be all 0
toCombinedAC :: LR (LR DamageVector) -> CombinedDamageVectorAC
toCombinedAC dv =
    { main: dv.left.left
    , enemyMain: dv.right.left
    , enemyEscort: dv.right.right
    }

-- | apply a single `DamageVector` on a single fleet
applyDamageVector :: DamageVector -> FleetInfo Ship -> FleetInfo Ship
applyDamageVector dv fleet = A.zipWith combine (getDV dv) fleet
  where
    combine :: Damage -> Maybe Ship -> Maybe Ship
    combine dmg ms = applyDamage dmg <$> ms

-- | apply `NormalDamageVector` on a normal fleet of ships (including enemy ships)
applyNormalDamageVector :: NormalDamageVector -> NormalFleetInfo Ship -> NormalFleetInfo Ship
applyNormalDamageVector ndv fleet =
    dupAsNormalBattle applyDamageVector
      `appNormalBattle` ndv
      `appNormalBattle` fleet

-- | apply `CombinedDamageVector` on a combined fleet of ships (including enemy ships)
applyCombinedDamageVector :: CombinedDamageVector -> CombinedFleetInfo Ship -> CombinedFleetInfo Ship
applyCombinedDamageVector ndv fleet =
    dupAsCombinedBattle applyDamageVector
      `appCombinedBattle` ndv
      `appCombinedBattle` fleet

{- | This module implements `DamageVector`:
   | an array of `Damage`s that can be applied to one fleet of `Ship`s.
   | most functions prefixed with `calc` in this module
   | produces either `LR DamageVector` or a single `DamageVector`.
   | which can then be converted `NormalDamageVector` or `CombinedDamageVector`
   | depending on what the corresponding data is standing for.
 -}
module KanColle.DamageAnalysis.DamageVector
  ( DamageVector, getDV, mkDV

  , NormalDamageVector
  , GCombinedDamageVector
  , CombinedDamageVector, CombinedDamageVectorAC
  , FleetRole(..)

  , calcKoukuDamage
  , calcKoukuDamageAC
  , calcKoukuDamageCombined
  , calcSupportAirAttackDamage
  , calcSupportAirAttackDamageAC
  , calcSupportHouraiDamage
  , calcSupportHouraiDamageAC
  , calcHougekiDamage
  , calcRaigekiDamage

  , calcRaigekiDamageAC
  , calcHougekiDamageAC

  , calcLandBasedKoukuDamage
--  , calcLandBasedKoukuDamageAC

  , toGCombined
  , toCombined
  , toCombinedAC

  , applyDamageVector
  , applyNormalDamageVector
  , applyCombinedDamageVector
  ) where

import Prelude
import Data.Monoid
import Data.Int as Int
import Data.Array as A
import Data.Array.ST as STA
import Data.Unfoldable hiding (fromMaybe)
import Control.Monad.Eff
import Control.Monad.ST as ST
import KanColle.Util
import KanColle.DamageAnalysis.Types
import KanColle.DamageAnalysis.Damage

import Data.Foreign
import Data.Foldable
import KanColle.KCAPI.Battle
import Data.Maybe
import Data.String (joinWith)

-- when flagship protection happens
-- and extra 0.1 will be added to that value
-- for our purpose we don't need to deal with that
-- so all damages can be normalized as Ints
normalizeDamage :: Number -> Int
normalizeDamage x
  | x >= 0.0 = Int.floor x
  | x == (-1.0) = 0
  | otherwise =
    let warning = "invalid damage number: " <> show x
    in traceWarn warning (\_ -> 0)

-- | `DamageVector` is a 6-element array of `Damage`s
newtype DamageVector = DV (Array Damage)

-- | fetches the array inside `DamageVector`
getDV :: DamageVector -> Array Damage
getDV (DV v) = v

-- | creates `DamageVector` from arrays.
-- | array has to be of length 6
mkDV :: Array Damage -> DamageVector
mkDV xs = if check
    then DV xs
    else throwWith "mkDV: array size should be 6"
  where
    check = A.length xs == 6

instance semigroupDamageVector :: Semigroup DamageVector where
  append (DV a) (DV b) = DV (A.zipWith (<>) a b)

instance monoidDamageVector :: Monoid DamageVector where
  mempty = DV (replicate 6 mempty)

-- | `DamageVector` for normal battles
type NormalDamageVector = NormalBattle DamageVector

-- | `DamageVector` for battles involving comined fleets
type GCombinedDamageVector = GCombinedBattle DamageVector
type CombinedDamageVector = CombinedBattle DamageVector
type CombinedDamageVectorAC = CombinedBattleAC DamageVector

debugShowDV :: DamageVector -> String
debugShowDV (DV xs) = joinWith "," (map (show <<< damageToInt) xs)

-- TODO: abandon this and always use the safe version
-- | get `DamageVector` from raw `fDam` and `eDam` fields
fromFDamAndEDam :: forall a.
                { api_fdam :: Array Number
                , api_edam :: Array Number | a} -> LR DamageVector
fromFDamAndEDam v =
    { left: DV (convertFEDam v.api_fdam)
    , right: DV (convertFEDam v.api_edam) }

fromFDamAndEDamSafe :: KoukuStage3 -> LR DamageVector
fromFDamAndEDamSafe ks3 =
    { left: DV (convertFEDam fDam)
    , right: DV (convertFEDam eDam) }
  where
    fDam = fromMaybe mempty (getKoukuStage3FDam ks3)
    eDam = fromMaybe mempty (getKoukuStage3EDam ks3)

-- L: ally fleet, LL: ally main, LR: ally escort
-- R: enemy fleet: RL: enemy main, RR: enemy escort
fromFDamAndEDamAC :: forall a.
                  { api_fdam :: Array Number
                  , api_edam :: Array Number | a} -> LR (LR DamageVector)
fromFDamAndEDamAC v = (lrMap >>> lrMap) DV
    { left: allyDams
    , right: enemyDams }
  where
    longFDam = convertFEDam v.api_fdam
    allyDams = fleetSplit false longFDam

    longEDam = convertFEDam v.api_edam
    enemyDams = fleetSplit false longEDam

-- (internal use only)
-- an "-1" is put in front of both api_fdam and api_edam
-- we first drop that element and then convert
-- integers intos Damages
convertFEDam :: Array Number -> Array Damage
convertFEDam = unsafeArrTail >>> map (normalizeDamage >>> mkDamage)

-- | calculate damage from kouku (aerial) stages
calcKoukuDamage :: Kouku -> LR DamageVector
calcKoukuDamage kk = fromFDamAndEDam kk.api_stage3

-- calcKoukuDamageAC :: Kouku -> LR DamageVector
-- calcKoukuDamageAC kk = fromFDamAndEDam kk.api_stage3_combined

-- | calculate damage from ally vs. enemy main fleet kouku stages (for Abyssal Combined fleet)
calcKoukuDamageACEMain :: forall a . {api_stage3 :: KoukuStage3 | a} -> LR DamageVector
calcKoukuDamageACEMain kk = fromFDamAndEDamSafe kk.api_stage3

-- | calculate damage from ally vs. enemy escort fleet kouku stages (for Abyssal Combined fleet)
calcKoukuDamageACEEscort :: forall a. {api_stage3_combined :: KoukuStage3 | a} -> LR DamageVector
calcKoukuDamageACEEscort kk = fromFDamAndEDamSafe kk.api_stage3_combined

calcKoukuDamageAC :: forall a.
                  { api_stage3 :: KoukuStage3
                  , api_stage3_combined :: KoukuStage3
                  | a} -> LR (LR DamageVector)
calcKoukuDamageAC kk =
    { left:
      { left: resultEMain.left <> resultEEscort.left
      , right: mempty }
    , right:
      { left: resultEMain.right
      , right: resultEEscort.right } }
  where
    resultEMain = calcKoukuDamageACEMain kk
    resultEEscort = calcKoukuDamageACEEscort kk

-- | calculate damage from kouku (aerial) stages (combined fleet)
-- | note that only escort fleet is taking damage. so we just need DamageVector
calcKoukuDamageCombined :: Kouku -> DamageVector
calcKoukuDamageCombined kk = DV (convertFEDam (kk.api_stage3_combined.api_fdam))

-- | calculate land based kouku damages. whose api_stage3 only have an api_edam field
-- | (because only enemies are taking damage)
calcLandBasedKoukuDamage :: Kouku -> DamageVector
calcLandBasedKoukuDamage lbkk = case maybeStage3 of
    Just stage3 -> DV (convertFEDam stage3.api_edam)
    Nothing -> mempty
  where
    maybeStage3 = getKoukuStage3 lbkk

{-
-- note: here .left means enemy main fleet and .right enemy escort
calcLandBasedKoukuDamageAC :: Kouku -> LR DamageVector
calcLandBasedKoukuDamageAC lbkk = case maybeStage3 of
    Just stage3 -> DV (convertFEDam stage3.api_edam)
    Nothing -> mempty
  where
    maybeStage3 = getKoukuStage3EEscortMaybe lbkk
-}

-- | calculate damage from raigeki (torpedo) stages
calcRaigekiDamage :: Raigeki -> LR DamageVector
calcRaigekiDamage = fromFDamAndEDam

calcRaigekiDamageAC :: Raigeki -> LR (LR DamageVector)
calcRaigekiDamageAC = fromFDamAndEDamAC

-- | calculate damage from hougeki (shelling) stages
calcHougekiDamage :: Hougeki -> LR DamageVector
calcHougekiDamage h =
    if lengthCheck
      then let resultArr = runPure (STA.runSTArray resultDV)
           in lrMap DV (fleetSplit false resultArr)
      else throwWith "invalid: api_df_list and api_damage length mismatch"
  where
    cAI :: Foreign -> Array Int
    cAI = unsafeFromForeign
    cAN :: Foreign -> Array Number
    cAN = unsafeFromForeign

    lengthCheck = A.length eventTargets == A.length eventDamages

    eventTargets :: Array Int
    eventTargets = map (cAI >>> toOne) (unsafeArrTail h.api_df_list)
      where
        -- merge targets like [a,a] into a-1 (so that it's zero-indexed)
        -- there are 2 checks:
        --   elements of api_df_list should:
        --   * be non-empty
        --   * all elements of it should be the same
        -- the reason for minus 1 in the end is to make it zero-based
        toOne :: Array Int -> Int
        toOne xs = case A.uncons xs of
          Just {head: y, tail: ys} ->
            if all (\v -> v == y) ys || all (\v -> v == -1) ys
              then y - 1
              else throwWith "invalid: elements are different in api_df_list"
          Nothing -> throwWith "invalid: empty api_df_list element"

    eventDamages :: Array Damage
    eventDamages = map (cAN >>> convert) (unsafeArrTail h.api_damage)
      where
        convert :: Array Number -> Damage
        convert xs = mkDamage totalDmg
          where
            -- there are double attacks in the damage list
            -- because damecon triggers *AFTER* the attack actions are completed
            -- we need to sum damage values before turning it into real Damage
            totalDmg = sum (map normalizeDamage xs :: Array Int)

    accumulateDamage :: forall h r.
                        STA.STArray h Damage -- array reference
                     -> Int -> Damage -- target index and corresponding damage
                     -> Eff (st :: ST.ST h | r) Unit
    accumulateDamage arr targetInd damage = do
        dmg <- peekSTArrayUnsafe arr targetInd
        pokeSTArrayUnsafe arr targetInd (dmg <> damage :: Damage)
        pure unit
    resultDV :: forall h r . Eff (st :: ST.ST h | r) (STA.STArray h Damage)
    resultDV = do
        arr <- STA.thaw (replicate 12 mempty)
        A.zipWithA (accumulateDamage arr) eventTargets eventDamages
        pure arr

calcHougekiDamageAC :: Hougeki -> LR (LR DamageVector)
calcHougekiDamageAC h =
    if lengthCheck
      then let resultArr = runPure (STA.runSTArray resultDV)
           in { left:
                { left: DV (A.slice 0 6 resultArr)
                , right: DV (A.slice 6 12 resultArr) }
              , right:
                { left: DV (A.slice 12 18 resultArr)
                , right: DV (A.slice 18 24 resultArr) }
              }
      else throwWith "invalid: api_df_list / api_damage / api_at_eflag length mismatch"
  where
    cAI :: Foreign -> Array Int
    cAI = unsafeFromForeign
    cAN :: Foreign -> Array Number
    cAN = unsafeFromForeign

    dfList = unsafeArrTail h.api_df_list
    atEFlag :: Array Int
    atEFlag = unsafeArrTail h.api_at_eflag
    damageList = unsafeArrTail h.api_damage

    lengthCheck = A.length dfList == A.length atEFlag
               && A.length dfList == A.length damageList

    eventTargetsRaw :: Array Int
    eventTargetsRaw = map (cAI >>> toOne) (unsafeArrTail h.api_df_list)
      where
        -- merge targets like [a,a] into a-1 (so that it's zero-indexed)
        -- there are 2 checks:
        --   elements of api_df_list should:
        --   * be non-empty
        --   * all elements of it should be the same
        -- the reason for minus 1 in the end is to make it zero-based
        toOne :: Array Int -> Int
        toOne xs = case A.uncons xs of
          Just {head: y, tail: ys} ->
            if all (\v -> v == y) ys || all (\v -> v == -1) ys
              then y - 1
              else throwWith "invalid: elements are different in api_df_list"
          Nothing -> throwWith "invalid: empty api_df_list element"

    eventTargets :: Array Int
    eventTargets = A.zipWith updateTarget eventTargetsRaw atEFlag
      where
        updateTarget rawTarget eFlag = case eFlag of
            -- ally attacks in this turn, so the target is an enemy
            0 -> rawTarget + 12
            -- enemy attacks in this turn, so the target is an ally
            -- nothing to be doing in this case
            1 -> rawTarget
            _ -> throwWith "invalid api_at_eflag element"

    eventDamages :: Array Damage
    eventDamages = map (cAN >>> convert) (unsafeArrTail h.api_damage)
      where
        convert :: Array Number -> Damage
        convert xs = mkDamage totalDmg
          where
            -- there are double attacks in the damage list
            -- because damecon triggers *AFTER* the attack actions are completed
            -- we need to sum damage values before turning it into real Damage
            totalDmg = sum (map normalizeDamage xs :: Array Int)
    accumulateDamage :: forall h r.
                        STA.STArray h Damage -- array reference
                     -> Int -> Damage -- target index and corresponding damage
                     -> Eff (st :: ST.ST h | r) Unit
    accumulateDamage arr targetInd damage = do
        dmg <- peekSTArrayUnsafe arr targetInd
        pokeSTArrayUnsafe arr targetInd (dmg <> damage :: Damage)
        pure unit
    resultDV :: forall h r . Eff (st :: ST.ST h | r) (STA.STArray h Damage)
    resultDV = do
        arr <- STA.thaw (replicate 24 mempty)
        A.zipWithA (accumulateDamage arr) eventTargets eventDamages
        pure arr

-- | calculate damage from support airstrike stages.
-- | note that only enemy is taking damage so this results in
-- | a single `DamageVector`.
calcSupportAirAttackDamage :: SupportAirInfo -> DamageVector
calcSupportAirAttackDamage info = DV $ convertFEDam info.api_stage3.api_edam

calcSupportAirAttackDamageAC :: SupportAirInfo -> LR (LR DamageVector)
calcSupportAirAttackDamageAC info = calcKoukuDamageAC info

-- | calculate damage from support shelling stages.
-- | note that only enemy is taking damage so this results in
-- | a single `DamageVector`.
calcSupportHouraiDamage :: SupportHouraiInfo -> DamageVector
calcSupportHouraiDamage info = DV $ convertFEDam info.api_damage

-- TODO: to be verified, for now I just guess it's an array of raw length 1+12
calcSupportHouraiDamageAC :: SupportHouraiInfo -> LR (LR DamageVector)
calcSupportHouraiDamageAC info = { left: memptyLR, right: lrMap mkDV converted }
  where
    converted = fleetSplit false (convertFEDam info.api_damage)

-- | ally fleet's role in this battle
data FleetRole
  = FRMain -- ally main vs. enemy main
  | FREscort -- ally escort vs. enemy main
  | FRSupport -- ally support exped vs. enemy main
  | FRLandBased -- ally LBAS vs. enemy main
--  | FRMainEEscort -- ally main vs. enemy escort
--  | FRLandBasedEEscort -- ally LBAS vs. enemy escort

-- | `toCombined role dv` converts a `LR DamageVector` whose left part
-- | is playing role `role` into `CombinedDamageVector`
toGCombined :: FleetRole -> LR DamageVector -> GCombinedDamageVector
toGCombined r dv = case r of
    FRMain      ->
        { allyMain: dv.left, allyEscort: mempty
        , enemyMain: dv.right, enemyEscort: mempty }
    FREscort    ->
        { allyMain: mempty, allyEscort: dv.left
        , enemyMain: dv.right, enemyEscort: mempty }
    FRSupport   ->
        { allyMain: mempty, allyEscort: mempty
        , enemyMain: dv.right, enemyEscort: mempty }
    FRLandBased ->
        { allyMain: mempty, allyEscort: mempty
        , enemyMain: dv.right, enemyEscort: mempty }
{-
    FRMainEEscort ->
        { allyMain: dv.left, allyEscort: mempty
        , enemyMain: mempty, enemyEscort: dv.right }
    FRLandBasedEEscort ->
        { allyMain: mempty, allyEscort: mempty
        , enemyMain: mempty, enemyEscort: dv.right }
-}

toCombined :: FleetRole -> LR DamageVector -> CombinedDamageVector
toCombined r dv = toCombinedBattle (toGCombined r dv)

-- TODO: add check on dv.left.right, which should be all 0
toCombinedAC :: LR (LR DamageVector) -> CombinedDamageVectorAC
toCombinedAC dv =
    { main: dv.left.left
    , enemyMain: dv.right.left
    , enemyEscort: dv.right.right
    }

-- | apply a single `DamageVector` on a single fleet
applyDamageVector :: DamageVector -> FleetInfo Ship -> FleetInfo Ship
applyDamageVector dv fleet = A.zipWith combine (getDV dv) fleet
  where
    combine :: Damage -> Maybe Ship -> Maybe Ship
    combine dmg ms = applyDamage dmg <$> ms

-- | apply `NormalDamageVector` on a normal fleet of ships (including enemy ships)
applyNormalDamageVector :: NormalDamageVector -> NormalFleetInfo Ship -> NormalFleetInfo Ship
applyNormalDamageVector ndv fleet =
    dupAsNormalBattle applyDamageVector
      `appNormalBattle` ndv
      `appNormalBattle` fleet

-- | apply `CombinedDamageVector` on a combined fleet of ships (including enemy ships)
applyCombinedDamageVector :: CombinedDamageVector -> CombinedFleetInfo Ship -> CombinedFleetInfo Ship
applyCombinedDamageVector ndv fleet =
    dupAsCombinedBattle applyDamageVector
      `appCombinedBattle` ndv
      `appCombinedBattle` fleet


Refactor/Minor: Better type signatures

Refactor/Minor: Better type signatures

module Main where

import Prelude ((+), (-), ($), (<>), bind, const, discard, pure, show, unit, Unit)

import Control.Monad.Aff (Canceler, launchAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION)

import Data.Maybe (Maybe(Just))

import Graphics.Canvas (CANVAS, Context2D, getCanvasElementById, getContext2D, setFillStyle, fillPath, rect)

import Network.HTTP.Affjax (Affjax, AJAX, get, post)

import Partial.Unsafe (unsafePartial)

import Pux (CoreEffects, EffModel, start)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Pux.Renderer.React (renderToDOM)

import Text.Smolder.HTML (button, div, h1)
import Text.Smolder.Markup (text, (#!))

data Event = Increment | Decrement | NoOp

type State = String

foldp :: forall fx. Event -> State -> EffModel State Event fx
foldp Increment n = { state: n <> "!", effects: [] }
foldp Decrement n = { state: n <> "?", effects: [] }
foldp NoOp      n = { state: n       , effects: [] }

view :: State -> HTML Event
view token =
  div do
    button #! onClick (const NoOp) $ text "Hired Hands"
    button #! onClick (const NoOp) $ text "Change displayed items"
    button #! onClick (const NoOp) $ text "Open shop for the day"
    h1 $ text token

getToken :: Eff _ (Canceler _)
getToken = launchAff $ do
  res <- get "/connect"
  liftEff $ continueBooting $ "" <> res.response

postPing :: String -> Eff _ (Canceler _)
postPing token = launchAff $ do
  res <- post "/ping" token
  liftEff $ log $ "POST /ping response: " <> res.response

continueBooting :: forall eff. String -> Eff _ Unit
continueBooting token = do
  _ <- postPing token
  launchPux token
  _ <- initCanvas
  pure unit

launchPux :: forall eff. State -> Eff (CoreEffects eff) Unit
launchPux initialState = do
  app <- start
    { initialState
    , view
    , foldp
    , inputs: []
    }
  renderToDOM "#app" app.markup app.input

initCanvas :: forall eff. Eff (canvas :: CANVAS | eff) Context2D
initCanvas = unsafePartial do
  Just canvas <- getCanvasElementById "canvas"
  ctx         <- getContext2D canvas
  _           <- setFillStyle "#0000FF" ctx
  fillPath ctx $ rect ctx { x: 250.0, y: 250.0, w: 100.0, h: 100.0 }

main :: Eff _ (Canceler _)
main = getToken

module Main where

import Prelude ((+), (-), ($), (<>), bind, const, discard, pure, show, unit, Unit)

import Control.Monad.Aff (Canceler, launchAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (EXCEPTION)

import Data.Foreign (Foreign)
import Data.Maybe (Maybe(Just))

import Graphics.Canvas (CANVAS, getCanvasElementById, getContext2D, setFillStyle, fillPath, rect)

import Network.HTTP.Affjax (affjax, Affjax, AJAX, defaultRequest, get, post)
import Network.HTTP.Affjax.Response (class Respondable)

import Partial.Unsafe (unsafePartial)

import Pux (CoreEffects, EffModel, start)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Pux.Renderer.React (renderToDOM)

import Text.Smolder.HTML (br, button, div, span, h1)
import Text.Smolder.Markup (text, (#!))

data Event = Increment | Decrement | NoOp

type State = String

foldp :: forall fx. Event -> State -> EffModel State Event fx
foldp Increment n = { state: n <> "!", effects: [] }
foldp Decrement n = { state: n <> "?", effects: [] }
foldp NoOp      n = { state: n       , effects: [] }

view :: State -> HTML Event
view token =
  div do
    button #! onClick (const NoOp) $ text "Hired Hands"
    button #! onClick (const NoOp) $ text "Change displayed items"
    button #! onClick (const NoOp) $ text "Open shop for the day"
    h1 $ text token

getToken = launchAff $ do
  res <- get "/connect"
  liftEff $ continueBooting $ "" <> res.response

postPing token = launchAff $ do
  res <- post "/ping" token
  liftEff $ log $ "POST /ping response: " <> res.response

continueBooting token = do
  _ <- postPing token

  launchPux token
  _ <- initCanvas
  pure unit

launchPux initialState = do
  app <- start
    { initialState
    , view
    , foldp
    , inputs: []
    }

  renderToDOM "#app" app.markup app.input

initCanvas = unsafePartial do
  Just canvas <- getCanvasElementById "canvas"
  ctx         <- getContext2D canvas
  _           <- setFillStyle "#0000FF" ctx
  fillPath ctx $ rect ctx { x: 250.0, y: 250.0, w: 100.0, h: 100.0 }

main = getToken


Trigger effectful traverse stack overflow in test

module Test.Main where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Data.Bifoldable (class Bifoldable, bifoldl, bifoldr, bifoldMap, bifoldrDefault, bifoldlDefault, bifoldMapDefaultR, bifoldMapDefaultL)
import Data.Bifunctor (class Bifunctor, bimap)
import Data.Bitraversable (class Bitraversable, bisequenceDefault, bitraverse, bisequence, bitraverseDefault)
import Data.Foldable (class Foldable, find, findMap, fold, foldMap, foldMapDefaultL, foldMapDefaultR, foldl, foldlDefault, foldr, foldrDefault, length, maximum, maximumBy, minimum, minimumBy, null, surroundMap)
import Data.FoldableWithIndex (class FoldableWithIndex, findWithIndex, foldMapWithIndex, foldMapWithIndexDefaultL, foldMapWithIndexDefaultR, foldlWithIndex, foldlWithIndexDefault, foldrWithIndex, foldrWithIndexDefault, surroundMapWithIndex)
import Data.Function (on)
import Data.FunctorWithIndex (class FunctorWithIndex, mapWithIndex)
import Data.Int (toNumber)
import Data.Maybe (Maybe(..))
import Data.Monoid (class Monoid, mempty)
import Data.Monoid.Additive (Additive(..))
import Data.Traversable (class Traversable, sequenceDefault, traverse, sequence, traverseDefault)
import Data.TraversableWithIndex (class TraversableWithIndex, traverseWithIndex)
import Math (abs)
import Test.Assert (ASSERT, assert)

foreign import arrayFrom1UpTo :: Int -> Array Int

main :: Eff (console :: CONSOLE, assert :: ASSERT) Unit
main = do
  log "Test foldableArray instance"
  testFoldableArrayWith 20

  assert $ foldMapDefaultL (\x -> [x]) [1, 2] == [1, 2]

  log "Test foldableArray instance is stack safe"
  testFoldableArrayWith 20000

  log "Test foldMapDefaultL"
  testFoldableFoldMapDefaultL 20

  log "Test foldMapDefaultR"
  testFoldableFoldMapDefaultR 20

  log "Test foldlDefault"
  testFoldableFoldlDefault 20

  log "Test foldrDefault"
  testFoldableFoldlDefault 20

  log "Test traversableArray instance"
  testTraversableArrayWith 20

  log "Test traversableArray instance is stack safe"
  testTraversableArrayWith 20000

  log "Test traverseDefault"
  testTraverseDefault 20

  log "Test sequenceDefault"
  testSequenceDefault 20

  log "Test foldableWithIndexArray instance"
  testFoldableWithIndexArrayWith 20

  log "Test foldableWithIndexArray instance is stack safe"
  testFoldableWithIndexArrayWith 20000

  log "Test FoldableWithIndex laws for array instance"
  testFoldableWithIndexLawsOn
    ["a", "b", "c"]
    (\i x -> [Tuple i x])
    (\x -> [x])

  log "Test traversableArrayWithIndex instance"
  testTraversableWithIndexArrayWith 20

  log "Test Bifoldable on `inclusive or`"
  testBifoldableIOrWith id 10 100 42

  log "Test bifoldMapDefaultL"
  testBifoldableIOrWith BFML 10 100 42

  log "Test bifoldMapDefaultR"
  testBifoldableIOrWith BFMR 10 100 42

  log "Test bifoldlDefault"
  testBifoldableIOrWith BFLD 10 100 42

  log "Test bifoldrDefault"
  testBifoldableIOrWith BFRD 10 100 42

  log "Test Bitraversable on `inclusive or`"
  testBitraversableIOrWith id

  log "Test bitraverseDefault"
  testBitraversableIOrWith BTD

  log "Test bisequenceDefault"
  testBitraversableIOrWith BSD

  log "Test find"
  assert $ find (_ == 10) [1, 5, 10] == Just 10
  assert $ find (\x -> x `mod` 2 == 0) [1, 4, 10] == Just 4

  log "Test findWithIndex"
  assert $ findWithIndex (\i x -> i == 2 && x `mod` 2 == 0) [1, 2, 4, 6] == Just 4

  log "Test findMap" *> do
    let pred x = if x > 5 then Just (x * 100) else Nothing
    assert $ findMap pred [1, 5, 10, 20] == Just 1000

  log "Test maximum"
  assert $ maximum (arrayFrom1UpTo 10) == Just 10

  log "Test maximumBy"
  assert $
    maximumBy (compare `on` abs)
              (map (negate <<< toNumber) (arrayFrom1UpTo 10))
      == Just (-10.0)

  log "Test minimum"
  assert $ minimum (arrayFrom1UpTo 10) == Just 1

  log "Test minimumBy"
  assert $
    minimumBy (compare `on` abs)
              (map (negate <<< toNumber) (arrayFrom1UpTo 10))
      == Just (-1.0)

  log "Test null"
  assert $ null Nothing == true
  assert $ null (Just 1) == false
  assert $ null [] == true
  assert $ null [0] == false
  assert $ null [0,1] == false

  log "Test length"
  assert $ length Nothing == 0
  assert $ length (Just 1) == 1
  assert $ length [] == 0
  assert $ length [1] == 1
  assert $ length [1, 2] == 2

  log "Test surroundMap"
  assert $ "*" == surroundMap "*" show ([] :: Array Int)
  assert $ "*1*" == surroundMap "*" show [1]
  assert $ "*1*2*" == surroundMap "*" show [1, 2]
  assert $ "*1*2*3*" == surroundMap "*" show [1, 2, 3]

  log "Test surroundMapWithIndex"
  assert $ "*" == surroundMapWithIndex "*" (\i x -> show i <> x) []
  assert $ "*0a*" == surroundMapWithIndex "*" (\i x -> show i <> x) ["a"]
  assert $ "*0a*1b*" == surroundMapWithIndex "*" (\i x -> show i <> x) ["a", "b"]
  assert $ "*0a*1b*2c*" == surroundMapWithIndex "*" (\i x -> show i <> x) ["a", "b", "c"]

  log "All done!"

testFoldableFWith
  :: forall f e
   . Foldable f
  => Eq (f Int)
  => (Int -> f Int)
  -> Int
  -> Eff (assert :: ASSERT | e) Unit
testFoldableFWith f n = do
  let dat = f n
  let expectedSum = (n / 2) * (n + 1)

  assert $ foldr (+) 0 dat == expectedSum
  assert $ foldl (+) 0 dat == expectedSum
  assert $ foldMap Additive dat == Additive expectedSum

testFoldableArrayWith :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testFoldableArrayWith = testFoldableFWith arrayFrom1UpTo

testFoldableWithIndexFWith
  :: forall f e
   . FoldableWithIndex Int f
  => Eq (f Int)
  => (Int -> f Int)
  -> Int
  -> Eff (assert :: ASSERT | e) Unit
testFoldableWithIndexFWith f n = do
  let dat = f n
  -- expectedSum = \Sum_{1 <= i <= n} i * i
  let expectedSum = n * (n + 1) * (2 * n + 1) / 6

  assert $ foldrWithIndex (\i x y -> (i + 1) * x + y) 0 dat == expectedSum
  assert $ foldlWithIndex (\i y x -> y + (i + 1) * x) 0 dat == expectedSum
  assert $ foldMapWithIndex (\i x -> Additive $ (i + 1) * x) dat == Additive expectedSum

testFoldableWithIndexArrayWith :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testFoldableWithIndexArrayWith = testFoldableWithIndexFWith arrayFrom1UpTo

data Tuple a b = Tuple a b
derive instance eqTuple :: (Eq a, Eq b) => Eq (Tuple a b)

-- test whether foldable laws hold, using foldMap and ifoldMap
testFoldableWithIndexLawsOn
  :: forall f i a m n e
   . FoldableWithIndex i f
  => FunctorWithIndex i f
  => Monoid m
  => Monoid n
  => Eq m
  => Eq n
  => f a
  -> (i -> a -> m)
  -> (a -> n)
  -> Eff (assert :: ASSERT | e) Unit
testFoldableWithIndexLawsOn c f g = do
  -- compatibility with FunctorWithIndex (not strictly necessary for a valid
  -- instance, but it's likely an error if this does not hold)
  assert $ foldMapWithIndex f c == fold (mapWithIndex f c)

  -- Compatiblity with Foldable
  assert $ foldMap g c == foldMapWithIndex (const g) c

  -- FoldableWithIndex laws
  assert $ foldMapWithIndex f c == foldMapWithIndexDefaultL f c
  assert $ foldMapWithIndex f c == foldMapWithIndexDefaultR f c

  -- These follow from the above laws, but they test whether ifoldlDefault and
  -- ifoldrDefault have been specified correctly.
  assert $ foldMapWithIndex f c == foldlWithIndexDefault (\i y x -> y <> f i x) mempty c
  assert $ foldMapWithIndex f c == foldrWithIndexDefault (\i x y -> f i x <> y) mempty c

testTraversableFWith
  :: forall f e
   . Traversable f
  => Eq (f Int)
  => (Int -> f Int)
  -> Int
  -> Eff (assert :: ASSERT | e) Unit
testTraversableFWith f n = do
  let dat = f n

  _ <- traverse pure dat

  assert $ traverse Just dat == Just dat
  assert $ traverse pure dat == [dat]
  assert $ traverse (\x -> if x < 10 then Just x else Nothing) dat == Nothing
  assert $ sequence (map Just dat) == traverse Just dat

testTraversableArrayWith :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testTraversableArrayWith = testTraversableFWith arrayFrom1UpTo

testTraversableWithIndexFWith
  :: forall f e
   . TraversableWithIndex Int f
  => Eq (f (Tuple Int Int))
  => Eq (f Int)
  => (Int -> f Int)
  -> Int
  -> Eff (assert :: ASSERT | e) Unit
testTraversableWithIndexFWith f n = do
  let dat = f n

  assert $ traverseWithIndex (\i -> Just <<< Tuple i) dat == Just (mapWithIndex Tuple dat)
  assert $ traverseWithIndex (const Just) dat == traverse Just dat
  assert $ traverseWithIndex (\i -> pure <<< Tuple i) dat == [mapWithIndex Tuple dat]
  assert $
    traverseWithIndex (const pure :: Int -> Int -> Array Int) dat ==
    traverse pure dat

testTraversableWithIndexArrayWith
  :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testTraversableWithIndexArrayWith = testTraversableWithIndexFWith arrayFrom1UpTo

-- structures for testing default `Foldable` implementations

newtype FoldMapDefaultL a = FML (Array a)
newtype FoldMapDefaultR a = FMR (Array a)
newtype FoldlDefault    a = FLD (Array a)
newtype FoldrDefault    a = FRD (Array a)

instance eqFML :: (Eq a) => Eq (FoldMapDefaultL a) where eq (FML l) (FML r) = l == r
instance eqFMR :: (Eq a) => Eq (FoldMapDefaultR a) where eq (FMR l) (FMR r) = l == r
instance eqFLD :: (Eq a) => Eq (FoldlDefault a)    where eq (FLD l) (FLD r) = l == r
instance eqFRD :: (Eq a) => Eq (FoldrDefault a)    where eq (FRD l) (FRD r) = l == r

-- implemented `foldl` and `foldr`, but default `foldMap` using `foldl`
instance foldableFML :: Foldable FoldMapDefaultL where
  foldMap f         = foldMapDefaultL f
  foldl f u (FML a) = foldl f u a
  foldr f u (FML a) = foldr f u a

-- implemented `foldl` and `foldr`, but default `foldMap`, using `foldr`
instance foldableFMR :: Foldable FoldMapDefaultR where
  foldMap f         = foldMapDefaultR f
  foldl f u (FMR a) = foldl f u a
  foldr f u (FMR a) = foldr f u a

-- implemented `foldMap` and `foldr`, but default `foldMap`
instance foldableDFL :: Foldable FoldlDefault where
  foldMap f (FLD a) = foldMap f a
  foldl f u         = foldlDefault f u
  foldr f u (FLD a) = foldr f u a

-- implemented `foldMap` and `foldl`, but default `foldr`
instance foldableDFR :: Foldable FoldrDefault where
  foldMap f (FRD a) = foldMap f a
  foldl f u (FRD a) = foldl f u a
  foldr f u         = foldrDefault f u

testFoldableFoldMapDefaultL :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testFoldableFoldMapDefaultL = testFoldableFWith (FML <<< arrayFrom1UpTo)

testFoldableFoldMapDefaultR :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testFoldableFoldMapDefaultR = testFoldableFWith (FMR <<< arrayFrom1UpTo)

testFoldableFoldlDefault :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testFoldableFoldlDefault = testFoldableFWith (FLD <<< arrayFrom1UpTo)

testFoldableFoldrDefault :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testFoldableFoldrDefault = testFoldableFWith (FRD <<< arrayFrom1UpTo)

-- structures for testing default `Traversable` implementations

newtype TraverseDefault a = TD (Array a)
newtype SequenceDefault a = SD (Array a)

instance eqTD :: (Eq a) => Eq (TraverseDefault a) where eq (TD l) (TD r) = l == r
instance eqSD :: (Eq a) => Eq (SequenceDefault a) where eq (SD l) (SD r) = l == r

instance functorTD :: Functor TraverseDefault where map f (TD a) = TD (map f a)
instance functorSD :: Functor SequenceDefault where map f (SD a) = SD (map f a)

instance foldableTD :: Foldable TraverseDefault where
  foldMap f (TD a) = foldMap f a
  foldr f u (TD a) = foldr f u a
  foldl f u (TD a) = foldl f u a

instance foldableSD :: Foldable SequenceDefault where
  foldMap f (SD a) = foldMap f a
  foldr f u (SD a) = foldr f u a
  foldl f u (SD a) = foldl f u a

instance traversableTD :: Traversable TraverseDefault where
  traverse f      = traverseDefault f
  sequence (TD a) = map TD (sequence a)

instance traversableSD :: Traversable SequenceDefault where
  traverse f (SD a) = map SD (traverse f a)
  sequence m        = sequenceDefault m

testTraverseDefault :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testTraverseDefault = testTraversableFWith (TD <<< arrayFrom1UpTo)

testSequenceDefault :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testSequenceDefault = testTraversableFWith (SD <<< arrayFrom1UpTo)

-- structure for testing bifoldable, picked `inclusive or` as it has both products and sums

data IOr l r = Both l r | Fst l | Snd r

instance eqIOr :: (Eq l, Eq r) => Eq (IOr l r) where
  eq (Both lFst lSnd) (Both rFst rSnd) = (lFst == rFst) && (lSnd == rSnd)
  eq (Fst l)          (Fst r)          = l == r
  eq (Snd l)          (Snd r)          = l == r
  eq _                _                = false

instance bifoldableIOr :: Bifoldable IOr where
  bifoldr l r u (Both fst snd) = l fst (r snd u)
  bifoldr l r u (Fst fst)      = l fst u
  bifoldr l r u (Snd snd)      = r snd u

  bifoldl l r u (Both fst snd) = r (l u fst) snd
  bifoldl l r u (Fst fst)      = l u fst
  bifoldl l r u (Snd snd)      = r u snd

  bifoldMap l r (Both fst snd) = l fst <> r snd
  bifoldMap l r (Fst fst)      = l fst
  bifoldMap l r (Snd snd)      = r snd

instance bifunctorIOr :: Bifunctor IOr where
  bimap f g (Both fst snd) = Both (f fst) (g snd)
  bimap f g (Fst fst)      = Fst (f fst)
  bimap f g (Snd snd)      = Snd (g snd)

instance bitraversableIOr :: Bitraversable IOr where
  bitraverse f g (Both fst snd) = Both <$> f fst <*> g snd
  bitraverse f g (Fst fst)      = Fst <$> f fst
  bitraverse f g (Snd snd)      = Snd <$> g snd

  bisequence (Both fst snd) = Both <$> fst <*> snd
  bisequence (Fst fst)      = Fst <$> fst
  bisequence (Snd snd)      = Snd <$> snd

testBifoldableIOrWith
  :: forall t e
   . Bifoldable t
  => Eq (t Int Int)
  => (forall l r. IOr l r -> t l r)
  -> Int
  -> Int
  -> Int
  -> Eff (assert :: ASSERT | e) Unit
testBifoldableIOrWith lift fst snd u = do
  assert $ bifoldr (+) (*) u (lift $ Both fst snd) == fst + (snd * u)
  assert $ bifoldr (+) (*) u (lift $ Fst fst)      == fst + u
  assert $ bifoldr (+) (*) u (lift $ Snd snd)      == snd * u

  assert $ bifoldl (+) (*) u (lift $ Both fst snd) == (u + fst) * snd
  assert $ bifoldl (+) (*) u (lift $ Fst fst)      == u + fst
  assert $ bifoldl (+) (*) u (lift $ Snd snd)      == u * snd

  assert $ bifoldMap Additive Additive (lift $ Both fst snd) == Additive (fst + snd)
  assert $ bifoldMap Additive Additive (lift $ Fst fst)      == Additive fst
  assert $ bifoldMap Additive Additive (lift $ Snd snd)      == Additive snd

testBitraversableIOrWith
  :: forall t e
   . Bitraversable t
  => Eq (t Boolean Boolean)
  => (forall l r. IOr l r -> t l r)
  -> Eff (assert :: ASSERT | e) Unit
testBitraversableIOrWith lift = do
  let just a = Just (lift a)
  assert $ bisequence (lift (Both (Just true) (Just false))) == just (Both true false)
  assert $ bisequence (lift (Fst (Just true)))               == just (Fst true  :: IOr Boolean Boolean)
  assert $ bisequence (lift (Snd (Just false)))              == just (Snd false :: IOr Boolean Boolean)
  assert $ bitraverse Just Just (lift (Both true false))     == just (Both true false)
  assert $ bitraverse Just Just (lift (Fst true))            == just (Fst true  :: IOr Boolean Boolean)
  assert $ bitraverse Just Just (lift (Snd false))           == just (Snd false :: IOr Boolean Boolean)

-- structures for testing default `Bifoldable` implementations

newtype BifoldMapDefaultL l r = BFML (IOr l r)
newtype BifoldMapDefaultR l r = BFMR (IOr l r)
newtype BifoldlDefault    l r = BFLD (IOr l r)
newtype BifoldrDefault    l r = BFRD (IOr l r)

instance eqBFML :: (Eq l, Eq r) => Eq (BifoldMapDefaultL l r) where eq (BFML l) (BFML r) = l == r
instance eqBFMR :: (Eq l, Eq r) => Eq (BifoldMapDefaultR l r) where eq (BFMR l) (BFMR r) = l == r
instance eqBFLD :: (Eq l, Eq r) => Eq (BifoldlDefault l r)    where eq (BFLD l) (BFLD r) = l == r
instance eqBFRD :: (Eq l, Eq r) => Eq (BifoldrDefault l r)    where eq (BFRD l) (BFRD r) = l == r

instance bifoldableBFML :: Bifoldable BifoldMapDefaultL where
  bifoldMap f g m        = bifoldMapDefaultL f g m
  bifoldr f g u (BFML m) = bifoldr f g u m
  bifoldl f g u (BFML m) = bifoldl f g u m

instance bifoldableBFMR :: Bifoldable BifoldMapDefaultR where
  bifoldMap f g m        = bifoldMapDefaultR f g m
  bifoldr f g u (BFMR m) = bifoldr f g u m
  bifoldl f g u (BFMR m) = bifoldl f g u m

instance bifoldableBFLD :: Bifoldable BifoldlDefault where
  bifoldMap f g (BFLD m) = bifoldMap f g m
  bifoldr f g u (BFLD m) = bifoldr f g u m
  bifoldl f g u m        = bifoldlDefault f g u m

instance bifoldableBFRD :: Bifoldable BifoldrDefault where
  bifoldMap f g (BFRD m) = bifoldMap f g m
  bifoldr f g u m        = bifoldrDefault f g u m
  bifoldl f g u (BFRD m) = bifoldl f g u m

-- structures for testing default `Bitraversable` implementations

newtype BitraverseDefault l r = BTD (IOr l r)
newtype BisequenceDefault l r = BSD (IOr l r)

instance eqBTD :: (Eq l, Eq r) => Eq (BitraverseDefault l r) where eq (BTD l) (BTD r) = l == r
instance eqBSD :: (Eq l, Eq r) => Eq (BisequenceDefault l r) where eq (BSD l) (BSD r) = l == r

instance bifunctorBTD :: Bifunctor BitraverseDefault where bimap f g (BTD m) = BTD (bimap f g m)
instance bifunctorBSD :: Bifunctor BisequenceDefault where bimap f g (BSD m) = BSD (bimap f g m)

instance bifoldableBTD :: Bifoldable BitraverseDefault where
  bifoldMap f g (BTD m) = bifoldMap f g m
  bifoldr f g u (BTD m) = bifoldr f g u m
  bifoldl f g u (BTD m) = bifoldl f g u m

instance bifoldableBSD :: Bifoldable BisequenceDefault where
  bifoldMap f g (BSD m) = bifoldMap f g m
  bifoldr f g u (BSD m) = bifoldr f g u m
  bifoldl f g u (BSD m) = bifoldl f g u m

instance bitraversableBTD :: Bitraversable BitraverseDefault where
  bitraverse f g     = bitraverseDefault f g
  bisequence (BTD m) = map BTD (bisequence m)

instance bitraversableBSD :: Bitraversable BisequenceDefault where
  bitraverse f g (BSD m) = map BSD (bitraverse f g m)
  bisequence m           = bisequenceDefault m

module Test.Main where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Data.Bifoldable (class Bifoldable, bifoldl, bifoldr, bifoldMap, bifoldrDefault, bifoldlDefault, bifoldMapDefaultR, bifoldMapDefaultL)
import Data.Bifunctor (class Bifunctor, bimap)
import Data.Bitraversable (class Bitraversable, bisequenceDefault, bitraverse, bisequence, bitraverseDefault)
import Data.Foldable (class Foldable, find, findMap, fold, foldMap, foldMapDefaultL, foldMapDefaultR, foldl, foldlDefault, foldr, foldrDefault, length, maximum, maximumBy, minimum, minimumBy, null, surroundMap)
import Data.FoldableWithIndex (class FoldableWithIndex, findWithIndex, foldMapWithIndex, foldMapWithIndexDefaultL, foldMapWithIndexDefaultR, foldlWithIndex, foldlWithIndexDefault, foldrWithIndex, foldrWithIndexDefault, surroundMapWithIndex)
import Data.Function (on)
import Data.FunctorWithIndex (class FunctorWithIndex, mapWithIndex)
import Data.Int (toNumber)
import Data.Maybe (Maybe(..))
import Data.Monoid (class Monoid, mempty)
import Data.Monoid.Additive (Additive(..))
import Data.Traversable (class Traversable, sequenceDefault, traverse, sequence, traverseDefault)
import Data.TraversableWithIndex (class TraversableWithIndex, traverseWithIndex)
import Math (abs)
import Test.Assert (ASSERT, assert)

foreign import arrayFrom1UpTo :: Int -> Array Int

main :: Eff (console :: CONSOLE, assert :: ASSERT) Unit
main = do
  log "Test foldableArray instance"
  testFoldableArrayWith 20

  assert $ foldMapDefaultL (\x -> [x]) [1, 2] == [1, 2]

  log "Test foldableArray instance is stack safe"
  testFoldableArrayWith 20000

  log "Test foldMapDefaultL"
  testFoldableFoldMapDefaultL 20

  log "Test foldMapDefaultR"
  testFoldableFoldMapDefaultR 20

  log "Test foldlDefault"
  testFoldableFoldlDefault 20

  log "Test foldrDefault"
  testFoldableFoldlDefault 20

  log "Test traversableArray instance"
  testTraversableArrayWith 20

  log "Test traversableArray instance is stack safe"
  testTraversableArrayWith 20000

  log "Test traverseDefault"
  testTraverseDefault 20

  log "Test sequenceDefault"
  testSequenceDefault 20

  log "Test foldableWithIndexArray instance"
  testFoldableWithIndexArrayWith 20

  log "Test foldableWithIndexArray instance is stack safe"
  testFoldableWithIndexArrayWith 20000

  log "Test FoldableWithIndex laws for array instance"
  testFoldableWithIndexLawsOn
    ["a", "b", "c"]
    (\i x -> [Tuple i x])
    (\x -> [x])

  log "Test traversableArrayWithIndex instance"
  testTraversableWithIndexArrayWith 20

  log "Test Bifoldable on `inclusive or`"
  testBifoldableIOrWith id 10 100 42

  log "Test bifoldMapDefaultL"
  testBifoldableIOrWith BFML 10 100 42

  log "Test bifoldMapDefaultR"
  testBifoldableIOrWith BFMR 10 100 42

  log "Test bifoldlDefault"
  testBifoldableIOrWith BFLD 10 100 42

  log "Test bifoldrDefault"
  testBifoldableIOrWith BFRD 10 100 42

  log "Test Bitraversable on `inclusive or`"
  testBitraversableIOrWith id

  log "Test bitraverseDefault"
  testBitraversableIOrWith BTD

  log "Test bisequenceDefault"
  testBitraversableIOrWith BSD

  log "Test find"
  assert $ find (_ == 10) [1, 5, 10] == Just 10
  assert $ find (\x -> x `mod` 2 == 0) [1, 4, 10] == Just 4

  log "Test findWithIndex"
  assert $ findWithIndex (\i x -> i == 2 && x `mod` 2 == 0) [1, 2, 4, 6] == Just 4

  log "Test findMap" *> do
    let pred x = if x > 5 then Just (x * 100) else Nothing
    assert $ findMap pred [1, 5, 10, 20] == Just 1000

  log "Test maximum"
  assert $ maximum (arrayFrom1UpTo 10) == Just 10

  log "Test maximumBy"
  assert $
    maximumBy (compare `on` abs)
              (map (negate <<< toNumber) (arrayFrom1UpTo 10))
      == Just (-10.0)

  log "Test minimum"
  assert $ minimum (arrayFrom1UpTo 10) == Just 1

  log "Test minimumBy"
  assert $
    minimumBy (compare `on` abs)
              (map (negate <<< toNumber) (arrayFrom1UpTo 10))
      == Just (-1.0)

  log "Test null"
  assert $ null Nothing == true
  assert $ null (Just 1) == false
  assert $ null [] == true
  assert $ null [0] == false
  assert $ null [0,1] == false

  log "Test length"
  assert $ length Nothing == 0
  assert $ length (Just 1) == 1
  assert $ length [] == 0
  assert $ length [1] == 1
  assert $ length [1, 2] == 2

  log "Test surroundMap"
  assert $ "*" == surroundMap "*" show ([] :: Array Int)
  assert $ "*1*" == surroundMap "*" show [1]
  assert $ "*1*2*" == surroundMap "*" show [1, 2]
  assert $ "*1*2*3*" == surroundMap "*" show [1, 2, 3]

  log "Test surroundMapWithIndex"
  assert $ "*" == surroundMapWithIndex "*" (\i x -> show i <> x) []
  assert $ "*0a*" == surroundMapWithIndex "*" (\i x -> show i <> x) ["a"]
  assert $ "*0a*1b*" == surroundMapWithIndex "*" (\i x -> show i <> x) ["a", "b"]
  assert $ "*0a*1b*2c*" == surroundMapWithIndex "*" (\i x -> show i <> x) ["a", "b", "c"]

  log "All done!"

testFoldableFWith
  :: forall f e
   . Foldable f
  => Eq (f Int)
  => (Int -> f Int)
  -> Int
  -> Eff (assert :: ASSERT | e) Unit
testFoldableFWith f n = do
  let dat = f n
  let expectedSum = (n / 2) * (n + 1)

  assert $ foldr (+) 0 dat == expectedSum
  assert $ foldl (+) 0 dat == expectedSum
  assert $ foldMap Additive dat == Additive expectedSum

testFoldableArrayWith :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testFoldableArrayWith = testFoldableFWith arrayFrom1UpTo

testFoldableWithIndexFWith
  :: forall f e
   . FoldableWithIndex Int f
  => Eq (f Int)
  => (Int -> f Int)
  -> Int
  -> Eff (assert :: ASSERT | e) Unit
testFoldableWithIndexFWith f n = do
  let dat = f n
  -- expectedSum = \Sum_{1 <= i <= n} i * i
  let expectedSum = n * (n + 1) * (2 * n + 1) / 6

  assert $ foldrWithIndex (\i x y -> (i + 1) * x + y) 0 dat == expectedSum
  assert $ foldlWithIndex (\i y x -> y + (i + 1) * x) 0 dat == expectedSum
  assert $ foldMapWithIndex (\i x -> Additive $ (i + 1) * x) dat == Additive expectedSum

testFoldableWithIndexArrayWith :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testFoldableWithIndexArrayWith = testFoldableWithIndexFWith arrayFrom1UpTo

data Tuple a b = Tuple a b
derive instance eqTuple :: (Eq a, Eq b) => Eq (Tuple a b)

-- test whether foldable laws hold, using foldMap and ifoldMap
testFoldableWithIndexLawsOn
  :: forall f i a m n e
   . FoldableWithIndex i f
  => FunctorWithIndex i f
  => Monoid m
  => Monoid n
  => Eq m
  => Eq n
  => f a
  -> (i -> a -> m)
  -> (a -> n)
  -> Eff (assert :: ASSERT | e) Unit
testFoldableWithIndexLawsOn c f g = do
  -- compatibility with FunctorWithIndex (not strictly necessary for a valid
  -- instance, but it's likely an error if this does not hold)
  assert $ foldMapWithIndex f c == fold (mapWithIndex f c)

  -- Compatiblity with Foldable
  assert $ foldMap g c == foldMapWithIndex (const g) c

  -- FoldableWithIndex laws
  assert $ foldMapWithIndex f c == foldMapWithIndexDefaultL f c
  assert $ foldMapWithIndex f c == foldMapWithIndexDefaultR f c

  -- These follow from the above laws, but they test whether ifoldlDefault and
  -- ifoldrDefault have been specified correctly.
  assert $ foldMapWithIndex f c == foldlWithIndexDefault (\i y x -> y <> f i x) mempty c
  assert $ foldMapWithIndex f c == foldrWithIndexDefault (\i x y -> f i x <> y) mempty c

testTraversableFWith
  :: forall f e
   . Traversable f
  => Eq (f Int)
  => (Int -> f Int)
  -> Int
  -> Eff (assert :: ASSERT | e) Unit
testTraversableFWith f n = do
  let dat = f n

  assert $ traverse Just dat == Just dat
  assert $ traverse pure dat == [dat]
  assert $ traverse (\x -> if x < 10 then Just x else Nothing) dat == Nothing
  assert $ sequence (map Just dat) == traverse Just dat

testTraversableArrayWith :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testTraversableArrayWith = testTraversableFWith arrayFrom1UpTo

testTraversableWithIndexFWith
  :: forall f e
   . TraversableWithIndex Int f
  => Eq (f (Tuple Int Int))
  => Eq (f Int)
  => (Int -> f Int)
  -> Int
  -> Eff (assert :: ASSERT | e) Unit
testTraversableWithIndexFWith f n = do
  let dat = f n

  assert $ traverseWithIndex (\i -> Just <<< Tuple i) dat == Just (mapWithIndex Tuple dat)
  assert $ traverseWithIndex (const Just) dat == traverse Just dat
  assert $ traverseWithIndex (\i -> pure <<< Tuple i) dat == [mapWithIndex Tuple dat]
  assert $
    traverseWithIndex (const pure :: Int -> Int -> Array Int) dat ==
    traverse pure dat

testTraversableWithIndexArrayWith
  :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testTraversableWithIndexArrayWith = testTraversableWithIndexFWith arrayFrom1UpTo

-- structures for testing default `Foldable` implementations

newtype FoldMapDefaultL a = FML (Array a)
newtype FoldMapDefaultR a = FMR (Array a)
newtype FoldlDefault    a = FLD (Array a)
newtype FoldrDefault    a = FRD (Array a)

instance eqFML :: (Eq a) => Eq (FoldMapDefaultL a) where eq (FML l) (FML r) = l == r
instance eqFMR :: (Eq a) => Eq (FoldMapDefaultR a) where eq (FMR l) (FMR r) = l == r
instance eqFLD :: (Eq a) => Eq (FoldlDefault a)    where eq (FLD l) (FLD r) = l == r
instance eqFRD :: (Eq a) => Eq (FoldrDefault a)    where eq (FRD l) (FRD r) = l == r

-- implemented `foldl` and `foldr`, but default `foldMap` using `foldl`
instance foldableFML :: Foldable FoldMapDefaultL where
  foldMap f         = foldMapDefaultL f
  foldl f u (FML a) = foldl f u a
  foldr f u (FML a) = foldr f u a

-- implemented `foldl` and `foldr`, but default `foldMap`, using `foldr`
instance foldableFMR :: Foldable FoldMapDefaultR where
  foldMap f         = foldMapDefaultR f
  foldl f u (FMR a) = foldl f u a
  foldr f u (FMR a) = foldr f u a

-- implemented `foldMap` and `foldr`, but default `foldMap`
instance foldableDFL :: Foldable FoldlDefault where
  foldMap f (FLD a) = foldMap f a
  foldl f u         = foldlDefault f u
  foldr f u (FLD a) = foldr f u a

-- implemented `foldMap` and `foldl`, but default `foldr`
instance foldableDFR :: Foldable FoldrDefault where
  foldMap f (FRD a) = foldMap f a
  foldl f u (FRD a) = foldl f u a
  foldr f u         = foldrDefault f u

testFoldableFoldMapDefaultL :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testFoldableFoldMapDefaultL = testFoldableFWith (FML <<< arrayFrom1UpTo)

testFoldableFoldMapDefaultR :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testFoldableFoldMapDefaultR = testFoldableFWith (FMR <<< arrayFrom1UpTo)

testFoldableFoldlDefault :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testFoldableFoldlDefault = testFoldableFWith (FLD <<< arrayFrom1UpTo)

testFoldableFoldrDefault :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testFoldableFoldrDefault = testFoldableFWith (FRD <<< arrayFrom1UpTo)

-- structures for testing default `Traversable` implementations

newtype TraverseDefault a = TD (Array a)
newtype SequenceDefault a = SD (Array a)

instance eqTD :: (Eq a) => Eq (TraverseDefault a) where eq (TD l) (TD r) = l == r
instance eqSD :: (Eq a) => Eq (SequenceDefault a) where eq (SD l) (SD r) = l == r

instance functorTD :: Functor TraverseDefault where map f (TD a) = TD (map f a)
instance functorSD :: Functor SequenceDefault where map f (SD a) = SD (map f a)

instance foldableTD :: Foldable TraverseDefault where
  foldMap f (TD a) = foldMap f a
  foldr f u (TD a) = foldr f u a
  foldl f u (TD a) = foldl f u a

instance foldableSD :: Foldable SequenceDefault where
  foldMap f (SD a) = foldMap f a
  foldr f u (SD a) = foldr f u a
  foldl f u (SD a) = foldl f u a

instance traversableTD :: Traversable TraverseDefault where
  traverse f      = traverseDefault f
  sequence (TD a) = map TD (sequence a)

instance traversableSD :: Traversable SequenceDefault where
  traverse f (SD a) = map SD (traverse f a)
  sequence m        = sequenceDefault m

testTraverseDefault :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testTraverseDefault = testTraversableFWith (TD <<< arrayFrom1UpTo)

testSequenceDefault :: forall eff. Int -> Eff (assert :: ASSERT | eff) Unit
testSequenceDefault = testTraversableFWith (SD <<< arrayFrom1UpTo)

-- structure for testing bifoldable, picked `inclusive or` as it has both products and sums

data IOr l r = Both l r | Fst l | Snd r

instance eqIOr :: (Eq l, Eq r) => Eq (IOr l r) where
  eq (Both lFst lSnd) (Both rFst rSnd) = (lFst == rFst) && (lSnd == rSnd)
  eq (Fst l)          (Fst r)          = l == r
  eq (Snd l)          (Snd r)          = l == r
  eq _                _                = false

instance bifoldableIOr :: Bifoldable IOr where
  bifoldr l r u (Both fst snd) = l fst (r snd u)
  bifoldr l r u (Fst fst)      = l fst u
  bifoldr l r u (Snd snd)      = r snd u

  bifoldl l r u (Both fst snd) = r (l u fst) snd
  bifoldl l r u (Fst fst)      = l u fst
  bifoldl l r u (Snd snd)      = r u snd

  bifoldMap l r (Both fst snd) = l fst <> r snd
  bifoldMap l r (Fst fst)      = l fst
  bifoldMap l r (Snd snd)      = r snd

instance bifunctorIOr :: Bifunctor IOr where
  bimap f g (Both fst snd) = Both (f fst) (g snd)
  bimap f g (Fst fst)      = Fst (f fst)
  bimap f g (Snd snd)      = Snd (g snd)

instance bitraversableIOr :: Bitraversable IOr where
  bitraverse f g (Both fst snd) = Both <$> f fst <*> g snd
  bitraverse f g (Fst fst)      = Fst <$> f fst
  bitraverse f g (Snd snd)      = Snd <$> g snd

  bisequence (Both fst snd) = Both <$> fst <*> snd
  bisequence (Fst fst)      = Fst <$> fst
  bisequence (Snd snd)      = Snd <$> snd

testBifoldableIOrWith
  :: forall t e
   . Bifoldable t
  => Eq (t Int Int)
  => (forall l r. IOr l r -> t l r)
  -> Int
  -> Int
  -> Int
  -> Eff (assert :: ASSERT | e) Unit
testBifoldableIOrWith lift fst snd u = do
  assert $ bifoldr (+) (*) u (lift $ Both fst snd) == fst + (snd * u)
  assert $ bifoldr (+) (*) u (lift $ Fst fst)      == fst + u
  assert $ bifoldr (+) (*) u (lift $ Snd snd)      == snd * u

  assert $ bifoldl (+) (*) u (lift $ Both fst snd) == (u + fst) * snd
  assert $ bifoldl (+) (*) u (lift $ Fst fst)      == u + fst
  assert $ bifoldl (+) (*) u (lift $ Snd snd)      == u * snd

  assert $ bifoldMap Additive Additive (lift $ Both fst snd) == Additive (fst + snd)
  assert $ bifoldMap Additive Additive (lift $ Fst fst)      == Additive fst
  assert $ bifoldMap Additive Additive (lift $ Snd snd)      == Additive snd

testBitraversableIOrWith
  :: forall t e
   . Bitraversable t
  => Eq (t Boolean Boolean)
  => (forall l r. IOr l r -> t l r)
  -> Eff (assert :: ASSERT | e) Unit
testBitraversableIOrWith lift = do
  let just a = Just (lift a)
  assert $ bisequence (lift (Both (Just true) (Just false))) == just (Both true false)
  assert $ bisequence (lift (Fst (Just true)))               == just (Fst true  :: IOr Boolean Boolean)
  assert $ bisequence (lift (Snd (Just false)))              == just (Snd false :: IOr Boolean Boolean)
  assert $ bitraverse Just Just (lift (Both true false))     == just (Both true false)
  assert $ bitraverse Just Just (lift (Fst true))            == just (Fst true  :: IOr Boolean Boolean)
  assert $ bitraverse Just Just (lift (Snd false))           == just (Snd false :: IOr Boolean Boolean)

-- structures for testing default `Bifoldable` implementations

newtype BifoldMapDefaultL l r = BFML (IOr l r)
newtype BifoldMapDefaultR l r = BFMR (IOr l r)
newtype BifoldlDefault    l r = BFLD (IOr l r)
newtype BifoldrDefault    l r = BFRD (IOr l r)

instance eqBFML :: (Eq l, Eq r) => Eq (BifoldMapDefaultL l r) where eq (BFML l) (BFML r) = l == r
instance eqBFMR :: (Eq l, Eq r) => Eq (BifoldMapDefaultR l r) where eq (BFMR l) (BFMR r) = l == r
instance eqBFLD :: (Eq l, Eq r) => Eq (BifoldlDefault l r)    where eq (BFLD l) (BFLD r) = l == r
instance eqBFRD :: (Eq l, Eq r) => Eq (BifoldrDefault l r)    where eq (BFRD l) (BFRD r) = l == r

instance bifoldableBFML :: Bifoldable BifoldMapDefaultL where
  bifoldMap f g m        = bifoldMapDefaultL f g m
  bifoldr f g u (BFML m) = bifoldr f g u m
  bifoldl f g u (BFML m) = bifoldl f g u m

instance bifoldableBFMR :: Bifoldable BifoldMapDefaultR where
  bifoldMap f g m        = bifoldMapDefaultR f g m
  bifoldr f g u (BFMR m) = bifoldr f g u m
  bifoldl f g u (BFMR m) = bifoldl f g u m

instance bifoldableBFLD :: Bifoldable BifoldlDefault where
  bifoldMap f g (BFLD m) = bifoldMap f g m
  bifoldr f g u (BFLD m) = bifoldr f g u m
  bifoldl f g u m        = bifoldlDefault f g u m

instance bifoldableBFRD :: Bifoldable BifoldrDefault where
  bifoldMap f g (BFRD m) = bifoldMap f g m
  bifoldr f g u m        = bifoldrDefault f g u m
  bifoldl f g u (BFRD m) = bifoldl f g u m

-- structures for testing default `Bitraversable` implementations

newtype BitraverseDefault l r = BTD (IOr l r)
newtype BisequenceDefault l r = BSD (IOr l r)

instance eqBTD :: (Eq l, Eq r) => Eq (BitraverseDefault l r) where eq (BTD l) (BTD r) = l == r
instance eqBSD :: (Eq l, Eq r) => Eq (BisequenceDefault l r) where eq (BSD l) (BSD r) = l == r

instance bifunctorBTD :: Bifunctor BitraverseDefault where bimap f g (BTD m) = BTD (bimap f g m)
instance bifunctorBSD :: Bifunctor BisequenceDefault where bimap f g (BSD m) = BSD (bimap f g m)

instance bifoldableBTD :: Bifoldable BitraverseDefault where
  bifoldMap f g (BTD m) = bifoldMap f g m
  bifoldr f g u (BTD m) = bifoldr f g u m
  bifoldl f g u (BTD m) = bifoldl f g u m

instance bifoldableBSD :: Bifoldable BisequenceDefault where
  bifoldMap f g (BSD m) = bifoldMap f g m
  bifoldr f g u (BSD m) = bifoldr f g u m
  bifoldl f g u (BSD m) = bifoldl f g u m

instance bitraversableBTD :: Bitraversable BitraverseDefault where
  bitraverse f g     = bitraverseDefault f g
  bisequence (BTD m) = map BTD (bisequence m)

instance bitraversableBSD :: Bitraversable BisequenceDefault where
  bitraverse f g (BSD m) = map BSD (bitraverse f g m)
  bisequence m           = bisequenceDefault m


test for fixed bug

test for fixed bug

module Test.Main where

import Prelude
import Control.Monad.Eff.Console
import Test.Unit
import Test.Unit.Console hiding (print)
import Data.Array
import Data.Foldable

import KanColle.Expedition
import KanColle.Expedition.Requirement
import KanColle.Expedition.Minimal
import KanColle.DamageAnalysis
import KanColle.SType
import Data.Foreign
import Data.Maybe

import BattleData

instance eqFleetRequirementForTest :: Eq FleetRequirement where
    eq r1 r2 = explainFleetRequirement r1 == explainFleetRequirement r2

mkShip :: SType -> Int -> Int -> Ship ()
mkShip st l d =
    { ammo: 0
    , morale: 0
    , stype: st
    , level: l
    , drumCount: d }

testFleet1 :: Fleet ()
testFleet1 =
    [ mkShip SS 18 0
    , mkShip SS 59 0
    , mkShip SSV 62 0
    , mkShip SSV 61 0
    ]

testFleet2 :: Fleet ()
testFleet2 =
    [ mkShip DD 31 0
    , mkShip DD 12 0
    , mkShip DD 12 0
    , mkShip DD 14 0
    ]

testFleet3 :: Fleet ()
testFleet3 =
    [ mkShip CL 33 1
    , mkShip DD 13 1
    , mkShip DD 12 1
    , mkShip DD 8 0
    , mkShip DD 14 1
    ]

testFleet4 :: Fleet ()
testFleet4 =
    [ mkShip DD 58 1
    , mkShip DD 31 1
    , mkShip DD 44 1
    , mkShip DD 39 1
    , mkShip DD 36 1
    , mkShip CL 41 1
    ]

testFleet5 :: Fleet ()
testFleet5 =
    [ mkShip CT 5 0
    , mkShip DD 1 0
    , mkShip DD 1 0
    ]

type MyTest e = Test (testOutput :: TestOutput | e)

-- TODO: cover all possible expeditions
testExpeditionHelper :: forall e. MyTest e
testExpeditionHelper =
    test "ExpeditionHelper" do
      assert "fleet test 1" $
        unsatisfiedRequirements 2 testFleet1 == []
      assert "fleet test 2" $
        getAvailableExpeditions testFleet1 == [1,2,3,6,27]
      assert "fleet test 3" $
        getAvailableExpeditions testFleet2 == [1,2,3,6,11,12]
      assert "fleet test 3" $
        getAvailableExpeditions testFleet3 == [1,2,3,4,5,6,9,11,12,21]
      assert "fleet test 4" $
        getAvailableExpeditions testFleet4 == [1,2,3,4,5,6,7,8,9,11,12,13,14,16,17,21,37]
      assert "Expedition #32, 3 ships should also do" $
        unsatisfiedRequirements 32 testFleet5 == []

-- TODO: break into stages
testDamageAnalyzer :: forall e. MyTest e
testDamageAnalyzer =
    test "DamageAnalyzer" do
      assert "battle sample 1" $
        trimInfo (analyzeBattle (unsafeFromForeign battle1)) == [Nothing] <>
          map Just [75,75,75,75-4,77,79-9
                   ,84-127,60-95,60-21-98,53-213-145,35-164,35-159-157]
      assert "battle sample 2" $
        trimInfo (analyzeBattle (unsafeFromForeign battle2)) ==
          map toMaybeInt [9999
                         ,15,15-3,18,18,9999,9999
                         ,90-81-41,55-116,28,28-236,70-121,70-131]
      assert "night battle sample 1" $
        trimInfo (analyzeNightBattle (unsafeFromForeign nightBattle1)) ==
          map toMaybeInt [9999
                         ,15,12,18,18,9999,9999,0,0,28-94,0,0,0]
      assert "night battle sample 2" $
        trimInfo (analyzeNightBattle (unsafeFromForeign nightBattle2)) ==
          map toMaybeInt [9999
                         ,75,75,6,69,23,43,0,41-181,21-124,0,0,9999]
      assert "aerial battle sample 1" $
        trimInfo (analyzeBattle (unsafeFromForeign aerialBattle1)) ==
          map toMaybeInt [9999
                         ,37,31,31,32,32,44-6,96,70,60,20,20,20]
  where
    toMaybeInt x = if x == 9999 then Nothing else Just x
    trimInfo :: forall a. Array (Maybe { currentHp:: Int | a}) -> Array (Maybe Int)
    trimInfo = (map <<< map) (\x -> x.currentHp)

testExpeditionMinimal :: forall e. MyTest e
testExpeditionMinimal =
    test "ExpeditionMinimalCost" $
      assert "minimal costs are likely to be achivable" $
        all verify expeditionIds
  where
    verify eId = checkExpedition eId fleet
      where
        fleet = case getExpeditionMinCost eId of
            ECost ec -> ec.fleet

main = runTest do
    testExpeditionHelper
    testDamageAnalyzer
    testExpeditionMinimal

module Test.Main where

import Prelude
import Control.Monad.Eff.Console
import Test.Unit
import Test.Unit.Console hiding (print)
import Data.Array
import Data.Foldable

import KanColle.Expedition
import KanColle.Expedition.Requirement
import KanColle.Expedition.Minimal
import KanColle.DamageAnalysis
import KanColle.SType
import Data.Foreign
import Data.Maybe

import BattleData

instance eqFleetRequirementForTest :: Eq FleetRequirement where
    eq r1 r2 = explainFleetRequirement r1 == explainFleetRequirement r2

mkShip :: SType -> Int -> Int -> Ship ()
mkShip st l d =
    { ammo: 0
    , morale: 0
    , stype: st
    , level: l
    , drumCount: d }

testFleet1 :: Fleet ()
testFleet1 =
    [ mkShip SS 18 0
    , mkShip SS 59 0
    , mkShip SSV 62 0
    , mkShip SSV 61 0
    ]

testFleet2 :: Fleet ()
testFleet2 =
    [ mkShip DD 31 0
    , mkShip DD 12 0
    , mkShip DD 12 0
    , mkShip DD 14 0
    ]

testFleet3 :: Fleet ()
testFleet3 =
    [ mkShip CL 33 1
    , mkShip DD 13 1
    , mkShip DD 12 1
    , mkShip DD 8 0
    , mkShip DD 14 1
    ]

testFleet4 :: Fleet ()
testFleet4 =
    [ mkShip DD 58 1
    , mkShip DD 31 1
    , mkShip DD 44 1
    , mkShip DD 39 1
    , mkShip DD 36 1
    , mkShip CL 41 1
    ]

type MyTest e = Test (testOutput :: TestOutput | e)

-- TODO: cover all possible expeditions
testExpeditionHelper :: forall e. MyTest e
testExpeditionHelper =
    test "ExpeditionHelper" do
      assert "fleet test 1" $
        unsatisfiedRequirements 2 testFleet1 == []
      assert "fleet test 2" $
        getAvailableExpeditions testFleet1 == [1,2,3,6,27]
      assert "fleet test 3" $
        getAvailableExpeditions testFleet2 == [1,2,3,6,11,12]
      assert "fleet test 3" $
        getAvailableExpeditions testFleet3 == [1,2,3,4,5,6,9,11,12,21]
      assert "fleet test 4" $
        getAvailableExpeditions testFleet4 == [1,2,3,4,5,6,7,8,9,11,12,13,14,16,17,21,37]

-- TODO: break into stages
testDamageAnalyzer :: forall e. MyTest e
testDamageAnalyzer =
    test "DamageAnalyzer" do
      assert "battle sample 1" $
        trimInfo (analyzeBattle (unsafeFromForeign battle1)) == [Nothing] <>
          map Just [75,75,75,75-4,77,79-9
                   ,84-127,60-95,60-21-98,53-213-145,35-164,35-159-157]
      assert "battle sample 2" $
        trimInfo (analyzeBattle (unsafeFromForeign battle2)) ==
          map toMaybeInt [9999
                         ,15,15-3,18,18,9999,9999
                         ,90-81-41,55-116,28,28-236,70-121,70-131]
      assert "night battle sample 1" $
        trimInfo (analyzeNightBattle (unsafeFromForeign nightBattle1)) ==
          map toMaybeInt [9999
                         ,15,12,18,18,9999,9999,0,0,28-94,0,0,0]
      assert "night battle sample 2" $
        trimInfo (analyzeNightBattle (unsafeFromForeign nightBattle2)) ==
          map toMaybeInt [9999
                         ,75,75,6,69,23,43,0,41-181,21-124,0,0,9999]
      assert "aerial battle sample 1" $
        trimInfo (analyzeBattle (unsafeFromForeign aerialBattle1)) ==
          map toMaybeInt [9999
                         ,37,31,31,32,32,44-6,96,70,60,20,20,20]
  where
    toMaybeInt x = if x == 9999 then Nothing else Just x
    trimInfo :: forall a. Array (Maybe { currentHp:: Int | a}) -> Array (Maybe Int)
    trimInfo = (map <<< map) (\x -> x.currentHp)

testExpeditionMinimal :: forall e. MyTest e
testExpeditionMinimal =
    test "ExpeditionMinimalCost" $
      assert "minimal costs are likely to be achivable" $
        all verify expeditionIds
  where
    verify eId = checkExpedition eId fleet
      where
        fleet = case getExpeditionMinCost eId of
            ECost ec -> ec.fleet

main = runTest do
    testExpeditionHelper
    testDamageAnalyzer
    testExpeditionMinimal