module Game.Mastermind.CodeSet (
C(..),
cube,
unions,
intersections,
intersectionsPQ,
(*&), (#*&),
) where
import qualified Data.NonEmpty.Class as NonEmptyC
import qualified Data.NonEmpty.Set as NonEmptySet
import qualified Data.NonEmpty as NonEmpty
import qualified Data.Set as Set
import Data.Function.HT (nest, )
import Data.Ord.HT (comparing, )
import Prelude hiding (null, )
class C set where
empty :: set a
union, intersection :: (Ord a) => set a -> set a -> set a
unit :: set a
leftNonEmptyProduct :: NonEmptySet.T a -> set a -> set a
flatten :: (Ord a) => set a -> [[a]]
symbols :: (Ord a) => set a -> Set.Set a
null :: set a -> Bool
size :: set a -> Integer
select :: set a -> Integer -> [a]
representationSize :: set a -> Int
-- | simplify set representation by combining set products where possible
compress :: (Ord a) => set a -> set a
cube :: (C set) => NonEmptySet.T a -> Int -> set a
cube alphabet n =
nest n (leftNonEmptyProduct alphabet) unit
unions :: (C set, Ord a) => [set a] -> set a
unions = foldr union empty
{-
Use a sorted list as a priority queue.
Using the set 'size' as priority would be an unnecessary effort.
Intersection makes sets smaller,
thus the procedure would always insert at the front.
This is what 'intersections' does anyway.
-}
intersectionsPQ :: (C set, Ord a) => NonEmpty.T [] (set a) -> set a
intersectionsPQ =
let go (NonEmpty.Cons (_, set) []) = set
go (NonEmpty.Cons (_,x) ((_,y):rest)) =
let sec = intersection x y
in go $
NonEmpty.insertBy
(comparing fst) (representationSize sec, sec) rest
in go .
NonEmptyC.sortBy (comparing fst) .
fmap (\set -> (representationSize set, set))
intersections :: (C set, Ord a) => NonEmpty.T [] (set a) -> set a
intersections = NonEmpty.foldl1 intersection . nonEmptySortKey size
-- cannot be easily generalized for inclusion in non-empty package
nonEmptySortKey :: (Ord b) => (a -> b) -> NonEmpty.T [] a -> NonEmpty.T [] a
nonEmptySortKey f =
fmap snd . NonEmptyC.sortBy (comparing fst) . fmap (\x -> (f x, x))
infixr 5 *&, #*&
{- |
Like 'leftNonEmptyProduct' but the left operand can be empty.
-}
(*&) :: (C set, Ord a) => Set.Set a -> set a -> set a
c *& set =
case NonEmptySet.fetch c of
Nothing -> empty
Just nec -> leftNonEmptyProduct nec set
(#*&) :: (C set) => a -> set a -> set a
c #*& set =
leftNonEmptyProduct (NonEmptySet.singleton c) set