{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
module Immutable.Test
  ( testSuite
  ) where

import           Data.List                        (sort)
import           Data.Vector                      (Vector, (!))
import qualified Data.Vector                      as V
import           Immutable.Shuffle
import           System.Random
import           Test.QuickCheck.Instances.Vector ()
import           Test.QuickCheck.Monadic
import           Test.Tasty
import           Test.Tasty.QuickCheck            as QC hiding (shuffle)


testSuite :: TestTree
testSuite = testGroup ""
  [ localOption (QuickCheckTests 10000) shuffleTestSuite
  , localOption (QuickCheckTests 0    ) performanceTest
  , localOption (QuickCheckTests 10000) maximalCycleTestSuite
  , localOption (QuickCheckTests 10000) derangementTestSuite
  ]

performanceTest :: TestTree
performanceTest = testGroup "Performance"
  [ QC.testProperty
      "Shuffling preserves length and elements"
      (monadicIO . sameLength)]

shuffleTestSuite :: TestTree
shuffleTestSuite = testGroup "shuffleM"
  [ QC.testProperty
      "shuffleM: Shuffling preserves length and elements"
       (monadicIO . isPermutationM @Int)
  , QC.testProperty
      "shuffle: Shuffling preserves length and elements"
       (monadicIO . isPermutation  @Int)
  ]

maximalCycleTestSuite :: TestTree
maximalCycleTestSuite = testGroup "maximalCycleM"
  [ QC.testProperty
      "maximalCycleM: maximal cycle does indeed produce a maximal cycle on [0..n]"
      (monadicIO . isMaximalCycleM)
  , QC.testProperty
      "maximalCycle: maximal cycle does indeed produce a maximal cycle on [0..n]"
      (monadicIO . isMaximalCycle)
  ]


derangementTestSuite :: TestTree
derangementTestSuite = testGroup "derangementM"
  [ QC.testProperty
      "derangementM: derangement does indeed produce a derangment on [0..n]."
      (monadicIO . isDerangementM)
  , QC.testProperty
      "derangement: derangement does indeed produce a derangment on [0..n]."
      (monadicIO . isDerangement)
  ]

sameLength :: () -> PropertyM IO Property
sameLength _ = do
    let v :: Vector Int = V.fromList [1..1000000]
    v' <- run $ shuffleM v
    pure $ length v === length v'


isPermutationM :: forall a . (Ord a , Show a, Arbitrary a) => Vector a -> PropertyM IO Property
isPermutationM v =
  do
    v'  <- run $ shuffleM v
    let ls  = V.toList v
    let ls' = V.toList v'
    pure $ sort ls === sort ls'


isPermutation :: forall a . (Ord a , Show a, Arbitrary a) => Vector a -> PropertyM IO Property
isPermutation v =
  do
    g        <- run getStdGen
    let (v', _) = shuffle v g
    let ls  = V.toList v
    let ls' = V.toList v'
    pure $ sort ls === sort ls'


isMaximalCycleM :: Positive Int -> PropertyM IO Property
isMaximalCycleM (Positive n) =
  do
    v <- run $ maximalCycleM (V.fromList [0..n])
    pure $ cycleLength v === (n + 1)

   where
     cycleLength :: Vector Int -> Int
     cycleLength v = go (V.head v) v

     go :: Int -> Vector Int -> Int
     go k xs = if k == 0
                       then 1
                     else
                       1 + go (xs ! k) xs

isMaximalCycle :: Positive Int -> PropertyM IO Property
isMaximalCycle (Positive n) =
  do
    g      <- run getStdGen
    let (v, _) = maximalCycle (V.fromList [0..n]) g
    pure $ cycleLength v === (n + 1)

   where
     cycleLength :: Vector Int -> Int
     cycleLength v = go (V.head v) v

     go :: Int -> Vector Int -> Int
     go k xs = if k == 0
                       then 1
                     else
                       1 + go (xs ! k) xs


isDerangementM :: Positive Int -> PropertyM IO Property
isDerangementM (Positive n) =
  do
    v <- run $ derangementM (V.fromList [0..n])
    let perm    = V.indexed v
    let unmoved = V.filter (uncurry (==)) perm
    pure $ null unmoved === True


isDerangement :: Positive Int -> PropertyM IO Property
isDerangement (Positive n) =
  do
    g      <- run getStdGen
    let (v, _)  = derangement (V.fromList [0.. n]) g
    let perm    = V.indexed v
    let unmoved = V.filter (uncurry (==)) perm
    pure $ null unmoved === True