Mastermind.hs

module Game.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 qualified Data.Set as Set
import Control.Monad (liftM2, )

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


alphabet :: Set.Set Int
alphabet = Set.fromList [0..9]


newtype Code = Code [Int]
   deriving (Show)

-- can we get it working with empty lists, too?
instance Arbitrary Code where
   arbitrary =
      fmap (Code . take 5 . map (flip mod 10)) $
      liftM2 (:) arbitrary arbitrary
--      fmap (Code . take 5 . map (flip mod 10)) arbitrary


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

instance Arbitrary CodePair where
   arbitrary =
      liftM2
         (\(Code xs) (Code ys) ->
            uncurry CodePair $ unzip $ zip xs ys)
         arbitrary arbitrary


remainingMember :: CodePair -> Bool
remainingMember (CodePair secret attempt) =
   CodeSetTree.member secret $
   MM.remaining 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))

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

remainingDisjoint :: Code -> Property
remainingDisjoint (Code attempt) =
   forAllEval attempt $ \eval0 ->
   forAllEval attempt $ \eval1 ->
   let remaining0 = MM.remaining alphabet attempt eval0
       remaining1 = MM.remaining alphabet attempt eval1
   in  eval0 == eval1 ||
       CodeSetTree.null
          (CodeSetTree.intersection remaining0 remaining1)

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

evaluateRemaining :: Code -> Property
evaluateRemaining (Code attempt) =
   forAllEval attempt $ \eval ->
       all ((eval ==) . MM.evaluate attempt) $
       take 100 $
       CodeSet.flatten $
       (MM.remaining alphabet attempt eval :: CodeSetTree.T Int)

{-
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 :: CodeSetTree.T Int
       set = MM.remaining alphabet attempt eval
   in  map (CodeSet.select set) [0 .. min 100 (CodeSet.size set) - 1]
       ==
       take 100 (CodeSet.flatten set)


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


{-
Other possible tests:

the products in a set produced by 'remaining' 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 =
   ("remainingMember", quickCheck remainingMember) :
   ("remainingNotMember", quickCheck remainingNotMember) :
   ("remainingDisjoint", quickCheck remainingDisjoint) :
   ("evaluateCommutative", quickCheck evaluateCommutative) :
   ("evaluateRemaining", quickCheck evaluateRemaining) :
   ("partitionSizes", quickCheck partitionSizes) :
   ("selectFlatten", quickCheck selectFlatten) :
   ("solve", quickCheck solve) :
   []