module BishBosh.Model.PositionHashTree(
PositionHashTree(),
countDistinctPositions,
mkPositionHashTree
) where
import qualified BishBosh.Component.Zobrist as Component.Zobrist
import qualified BishBosh.Data.Exception as Data.Exception
import qualified BishBosh.Model.Game as Model.Game
import qualified BishBosh.Model.GameTree as Model.GameTree
import qualified BishBosh.Property.Arboreal as Property.Arboreal
import qualified BishBosh.Text.ShowList as Text.ShowList
import qualified BishBosh.Types as T
import qualified Control.Exception
import qualified Data.Array.IArray
import qualified Data.Bits
import qualified Data.Default
import qualified Data.List
import qualified Data.Set
import qualified Data.Tree
import qualified System.Random
type BarePositionHashTree positionHash = Data.Tree.Tree positionHash
newtype PositionHashTree positionHash = MkPositionHashTree {
PositionHashTree positionHash -> BarePositionHashTree positionHash
deconstruct :: BarePositionHashTree positionHash
}
instance (
Data.Bits.FiniteBits positionHash,
System.Random.Random positionHash
) => Data.Default.Default (PositionHashTree positionHash) where
def :: PositionHashTree positionHash
def = Zobrist X X positionHash
-> GameTree X X -> PositionHashTree positionHash
forall x positionHash y.
(Ix x, Bits positionHash, Enum x, Enum y, Ord y) =>
Zobrist x y positionHash
-> GameTree x y -> PositionHashTree positionHash
mkPositionHashTree Zobrist X X positionHash
forall a. Default a => a
Data.Default.def (GameTree X X
forall a. Default a => a
Data.Default.def :: Model.GameTree.GameTree T.X T.Y)
mkPositionHashTree :: (
Data.Array.IArray.Ix x,
Data.Bits.Bits positionHash,
Enum x,
Enum y,
Ord y
)
=> Component.Zobrist.Zobrist x y positionHash
-> Model.GameTree.GameTree x y
-> PositionHashTree positionHash
mkPositionHashTree :: Zobrist x y positionHash
-> GameTree x y -> PositionHashTree positionHash
mkPositionHashTree Zobrist x y positionHash
zobrist = BarePositionHashTree positionHash -> PositionHashTree positionHash
forall positionHash.
BarePositionHashTree positionHash -> PositionHashTree positionHash
MkPositionHashTree (BarePositionHashTree positionHash
-> PositionHashTree positionHash)
-> (GameTree x y -> BarePositionHashTree positionHash)
-> GameTree x y
-> PositionHashTree positionHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Game x y -> positionHash)
-> Tree (Game x y) -> BarePositionHashTree positionHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Game x y -> Zobrist x y positionHash -> positionHash
forall positionHash (hashable :: * -> * -> *) x y.
(Bits positionHash, Hashable2D hashable x y) =>
hashable x y -> Zobrist x y positionHash -> positionHash
`Component.Zobrist.hash2D` Zobrist x y positionHash
zobrist) (Tree (Game x y) -> BarePositionHashTree positionHash)
-> (GameTree x y -> Tree (Game x y))
-> GameTree x y
-> BarePositionHashTree positionHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GameTree x y -> Tree (Game x y)
forall x y. GameTree x y -> BareGameTree x y
Model.GameTree.deconstruct
countDistinctPositions
:: Ord positionHash
=> Property.Arboreal.Depth
-> PositionHashTree positionHash
-> Model.Game.NGames
{-# SPECIALISE countDistinctPositions :: Property.Arboreal.Depth -> PositionHashTree T.PositionHash -> Model.Game.NGames #-}
countDistinctPositions :: X -> PositionHashTree positionHash -> X
countDistinctPositions X
depth MkPositionHashTree { deconstruct :: forall positionHash.
PositionHashTree positionHash -> BarePositionHashTree positionHash
deconstruct = BarePositionHashTree positionHash
barePositionHashTree }
| X
depth X -> X -> Bool
forall a. Ord a => a -> a -> Bool
< X
0 = Exception -> X
forall a e. Exception e => e -> a
Control.Exception.throw (Exception -> X) -> (String -> Exception) -> String -> X
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Exception
Data.Exception.mkOutOfBounds (String -> Exception) -> (String -> String) -> String -> Exception
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
"BishBosh.Component.PositionHashTree.countDistinctPositions:\tdepth" (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
Text.ShowList.showsAssociation (String -> X) -> String -> X
forall a b. (a -> b) -> a -> b
$ X -> String -> String
forall a. Show a => a -> String -> String
shows X
depth String
"must be positive"
| Bool
otherwise = Set positionHash -> X
forall a. Set a -> X
Data.Set.size (Set positionHash -> X) -> Set positionHash -> X
forall a b. (a -> b) -> a -> b
$ X -> BarePositionHashTree positionHash -> Set positionHash
forall t a. (Num t, Ord a, Enum t, Eq t) => t -> Tree a -> Set a
slave X
depth BarePositionHashTree positionHash
barePositionHashTree
where
slave :: t -> Tree a -> Set a
slave t
0 Data.Tree.Node { rootLabel :: forall a. Tree a -> a
Data.Tree.rootLabel = a
hash } = a -> Set a
forall a. a -> Set a
Data.Set.singleton a
hash
slave t
_ Data.Tree.Node {
rootLabel :: forall a. Tree a -> a
Data.Tree.rootLabel = a
hash,
subForest :: forall a. Tree a -> Forest a
Data.Tree.subForest = []
} = a -> Set a
forall a. a -> Set a
Data.Set.singleton a
hash
slave t
depth' Data.Tree.Node { subForest :: forall a. Tree a -> Forest a
Data.Tree.subForest = [Tree a]
forest } = (Set a -> Tree a -> Set a) -> Set a -> [Tree a] -> Set a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Data.List.foldl' (
\Set a
s -> Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Data.Set.union Set a
s (Set a -> Set a) -> (Tree a -> Set a) -> Tree a -> Set a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Tree a -> Set a
slave (t -> t
forall a. Enum a => a -> a
pred t
depth')
) Set a
forall a. Set a
Data.Set.empty [Tree a]
forest