Mastermind.hs

module Test.Mastermind (tests) where

import qualified Game.Mastermind.CodeSet.Tree as CodeSetTree
-- import qualified Game.Mastermind.CodeSet.Union as CodeSetUnion
import qualified Game.Mastermind.CodeSet as CodeSet
import qualified Game.Mastermind as MM

import Control.Monad (liftM2, )
import Control.Applicative ((<$>), )

import qualified Data.NonEmpty.Set as NonEmptySet
import qualified Data.Traversable as Trav
import qualified Data.Set as Set
import Data.NonEmpty ((!:))

import qualified Test.QuickCheck as QC
import Test.QuickCheck (Property, Arbitrary(arbitrary), quickCheck, (==>), )


alphabet :: Set.Set Int
alphabet = NonEmptySet.flatten neAlphabet

neAlphabet :: NonEmptySet.T Int
neAlphabet = NonEmptySet.fromList $ 0!:[1..9]


newtype Code = Code [Int]
   deriving (Show)


genElement :: QC.Gen Int
genElement = QC.choose (0,9)

-- can we get it working with empty lists, too?
genCode :: Int -> QC.Gen Code
genCode width =
   fmap (Code . take width) $ QC.listOf1 genElement
--    fmap (Code . take width) (QC.listOf genElement)

instance Arbitrary Code where
   arbitrary = genCode 5


data CodePair = CodePair [Int] [Int]
   deriving (Show)

genCodePair :: Int -> QC.Gen CodePair
genCodePair width =
   liftM2
      (\(Code xs) (Code ys) ->
         uncurry CodePair $ unzip $ zip xs ys)
      (genCode width) (genCode width)

instance Arbitrary CodePair where
   arbitrary = genCodePair 5


matchingMember :: CodePair -> Bool
matchingMember (CodePair secret attempt) =
   CodeSetTree.member secret $
   MM.matching alphabet attempt (MM.evaluate secret attempt)

genEval :: Int -> QC.Gen MM.Eval
genEval size = do
   total <- QC.frequency $ map (\k -> (k+1, return k)) [1 .. size]
   rightPlaces <- QC.choose (0,total)
   return $ MM.Eval rightPlaces (total - rightPlaces)

forAllEval :: QC.Testable prop => [a] -> (MM.Eval -> prop) -> Property
forAllEval code = QC.forAll (genEval (length code))

matchingNotMember :: CodePair -> Property
matchingNotMember (CodePair secret attempt) =
   forAllEval secret $ \eval ->
      (eval == MM.evaluate secret attempt)
      ==
      (CodeSetTree.member secret $ MM.matching alphabet attempt eval)

matchingDisjoint :: Code -> Property
matchingDisjoint (Code attempt) =
   forAllEval attempt $ \eval0 ->
   forAllEval attempt $ \eval1 ->
   let matching0 = MM.matching alphabet attempt eval0
       matching1 = MM.matching alphabet attempt eval1
   in  eval0 == eval1 ||
       CodeSetTree.null (CodeSetTree.intersection matching0 matching1)

evaluateCommutative :: CodePair -> Bool
evaluateCommutative (CodePair secret attempt) =
   MM.evaluate secret attempt
   ==
   MM.evaluate attempt secret


type CodeSetInt = CodeSetTree.T Int

evaluateMatching :: Code -> Property
evaluateMatching (Code attempt) =
   forAllEval attempt $ \eval ->
       all ((eval ==) . MM.evaluate attempt) $
       take 100 $
       CodeSet.flatten $
       (MM.matching alphabet attempt eval :: CodeSetInt)

{-
A more precise test would be to check
that for different numbers of rightPlace and rightSymbol
the codesets are disjoint
and their union is the set of all possible codes.
To this end we need a union with simplification or a subset test.
-}
partitionSizes :: Code -> Bool
partitionSizes (Code attempt) =
   fromIntegral (Set.size alphabet) ^ length attempt
   ==
   sum (map snd (MM.partitionSizes alphabet attempt))


selectFlatten :: Code -> Property
selectFlatten (Code attempt) =
   forAllEval attempt $ \eval ->
   let set :: CodeSetInt
       set = MM.matching alphabet attempt eval
   in  map (CodeSet.select set) [0 .. min 100 (CodeSet.size set) - 1]
       ==
       take 100 (CodeSet.flatten set)


genFixedLengthCodes :: Int -> QC.Gen [[Int]]
genFixedLengthCodes width = QC.listOf1 $ QC.vectorOf width genElement

bestSeparatingCode :: Property
bestSeparatingCode =
   QC.forAll (genCodePair 4) $ \(CodePair base0 base1) ->
   forAllEval base0 $ \eval0 ->
   forAllEval base1 $ \eval1 -> do
   let width = length base0
       set =
         CodeSet.intersection
            (MM.matching alphabet base0 eval0)
            (MM.matching alphabet base1 eval1)
   not (CodeSet.null set) ==>
      QC.forAll (fmap (take 10) $ genFixedLengthCodes width) $
         MM.propBestSeparatingCode width (set :: CodeSetInt)

intersections :: Property
intersections =
   QC.forAll (genCode 4) $ \(Code code) ->
   QC.forAll (fmap (take 10) $ genFixedLengthCodes (length code)) $ \codes ->
   QC.forAll (Trav.mapM (\x -> (,) x <$> genEval (length code)) (code!:codes)) $
      CodeSetTree.propIntersections . fmap (uncurry $ MM.matching alphabet)



-- should also work, when selecting any code from the set of matching codes
solve :: Code -> Bool
solve (Code secret) =
   let recourse remain =
          case CodeSet.flatten remain of
             [] -> False
             [attempt] -> secret == attempt
             attempt:_ ->
                recourse $ CodeSet.intersection remain $
                MM.matching alphabet attempt $ MM.evaluate secret attempt
   in  recourse (CodeSet.cube neAlphabet (length secret) :: CodeSetInt)


{-
Other possible tests:

the products in a set produced by 'MM.matching' must be disjoint.

set laws for the two set implementations,
   such as distributivity of union and intersection

check member against intersection with singleton
-}

tests :: [(String, IO ())]
tests =
   ("matchingMember", quickCheck matchingMember) :
   ("matchingNotMember", quickCheck matchingNotMember) :
   ("matchingDisjoint", quickCheck matchingDisjoint) :
   ("evaluateCommutative", quickCheck evaluateCommutative) :
   ("evaluateMatching", quickCheck evaluateMatching) :
   ("partitionSizes", quickCheck partitionSizes) :
   ("selectFlatten", quickCheck selectFlatten) :
   ("bestSeparatingCode", quickCheck bestSeparatingCode) :
   ("intersections", quickCheck intersections) :
   ("solve", quickCheck solve) :
   []