module BishBosh.ContextualNotation.QualifiedMoveForest(
Name,
OnymousResult,
QualifiedMoveForest(
deconstruct
),
showsNames,
findMinimumPieces,
count,
fromPGNDatabase,
toGameTree,
mergePGNDatabase,
) where
import Control.Applicative((<|>))
import Control.Arrow((&&&), (***))
import qualified BishBosh.Attribute.MoveType as Attribute.MoveType
import qualified BishBosh.Component.Move as Component.Move
import qualified BishBosh.Component.Piece as Component.Piece
import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove
import qualified BishBosh.Component.Turn as Component.Turn
import qualified BishBosh.ContextualNotation.PGN as ContextualNotation.PGN
import qualified BishBosh.ContextualNotation.PGNDatabase as ContextualNotation.PGNDatabase
import qualified BishBosh.Data.RoseTree as Data.RoseTree
import qualified BishBosh.Model.Game as Model.Game
import qualified BishBosh.Model.GameTerminationReason as Model.GameTerminationReason
import qualified BishBosh.Model.GameTree as Model.GameTree
import qualified BishBosh.Model.Result as Model.Result
import qualified BishBosh.Notation.MoveNotation as Notation.MoveNotation
import qualified BishBosh.Property.Empty as Property.Empty
import qualified BishBosh.Property.Null as Property.Null
import qualified BishBosh.State.Board as State.Board
import qualified BishBosh.Text.ShowList as Text.ShowList
import qualified BishBosh.Types as T
import qualified Control.Arrow
import qualified Data.Default
import qualified Data.List
import qualified Data.Maybe
import qualified Data.Tree
type Name = String
type OnymousResult = (Name, Model.Result.Result)
type QualifiedMoveTree x y = Data.Tree.Tree (Component.QualifiedMove.QualifiedMove x y, Maybe OnymousResult)
newtype QualifiedMoveForest x y = MkQualifiedMoveForest {
deconstruct :: [QualifiedMoveTree x y]
} deriving (
Eq,
Show
)
instance Property.Empty.Empty (QualifiedMoveForest x y) where
empty = MkQualifiedMoveForest []
instance Property.Null.Null (QualifiedMoveForest x y) where
isNull MkQualifiedMoveForest { deconstruct = [] } = True
isNull _ = False
instance (Enum x, Enum y) => Notation.MoveNotation.ShowNotation (QualifiedMoveForest x y) where
showsNotation moveNotation MkQualifiedMoveForest { deconstruct = forest } = showString $ Data.RoseTree.drawForest (
\(qualifiedMove, maybeOnymousResult) -> Notation.MoveNotation.showsNotation moveNotation qualifiedMove $ Data.Maybe.maybe id (
\onymousResult -> showChar ' ' . shows onymousResult
) maybeOnymousResult ""
) forest
showsNames
:: Maybe Int
-> [Name]
-> ShowS
showsNames maybeMaximumPGNNames names = Text.ShowList.showsUnterminatedList . map (
\name -> showString "\n\t" . showString name
) $ Data.Maybe.maybe id (
\maximumPGNNames -> (
if maximumPGNNames < length names'
then (++ ["..."])
else id
) . take maximumPGNNames
) maybeMaximumPGNNames names' where
names' = Data.List.nub $ Data.List.sort names
mergePGNDatabase
:: (Eq x, Eq y)
=> ContextualNotation.PGNDatabase.PGNDatabase x y
-> QualifiedMoveForest x y
-> QualifiedMoveForest x y
mergePGNDatabase pgnDatabase MkQualifiedMoveForest { deconstruct = initialForest } = MkQualifiedMoveForest $ foldr (
\pgn -> merge (
mkCompositeIdentifier &&& Data.Maybe.maybe (
Model.Result.mkResult Nothing
) Model.GameTerminationReason.toResult . Model.Game.getMaybeTerminationReason . ContextualNotation.PGN.getGame $ pgn
) (
map Component.Turn.getQualifiedMove . Model.Game.listTurnsChronologically $ ContextualNotation.PGN.getGame pgn
)
) initialForest pgnDatabase where
mkCompositeIdentifier :: ContextualNotation.PGN.PGN x y -> Name
mkCompositeIdentifier = unwords . map snd . ContextualNotation.PGN.getIdentificationTagPairs
merge
:: (Eq x, Eq y)
=> OnymousResult
-> [Component.QualifiedMove.QualifiedMove x y]
-> [QualifiedMoveTree x y]
-> [QualifiedMoveTree x y]
merge onymousResult qualifiedMoves@(qualifiedMove : remainingQualifiedMoves) forest = case span (
\Data.Tree.Node { Data.Tree.rootLabel = (qualifiedMove', _) } -> Component.QualifiedMove.getMove qualifiedMove /= Component.QualifiedMove.getMove qualifiedMove'
) forest of
(unmatchedForest, matchingTree : remainingForest) -> unmatchedForest ++ (
if null remainingQualifiedMoves
then matchingTree {
Data.Tree.rootLabel = Control.Arrow.second (
<|> Just onymousResult
) $ Data.Tree.rootLabel matchingTree
}
else matchingTree {
Data.Tree.subForest = merge onymousResult remainingQualifiedMoves $ Data.Tree.subForest matchingTree
}
) : remainingForest
_ -> mkLinkedList onymousResult qualifiedMoves : forest
merge _ [] forest = forest
mkLinkedList :: OnymousResult -> [Component.QualifiedMove.QualifiedMove x y] -> QualifiedMoveTree x y
mkLinkedList onymousResult ~(qualifiedMove : remainingQualifiedMoves)
| null remainingQualifiedMoves = Data.Tree.Node {
Data.Tree.rootLabel = (qualifiedMove, Just onymousResult),
Data.Tree.subForest = []
}
| otherwise = Data.Tree.Node {
Data.Tree.rootLabel = (qualifiedMove, Nothing),
Data.Tree.subForest = [mkLinkedList onymousResult remainingQualifiedMoves ]
}
fromPGNDatabase :: (Eq x, Eq y) => ContextualNotation.PGNDatabase.PGNDatabase x y -> QualifiedMoveForest x y
fromPGNDatabase = (`mergePGNDatabase` Property.Empty.empty )
findMinimumPieces :: QualifiedMoveForest x y -> Component.Piece.NPieces
findMinimumPieces = slave (
State.Board.getNPieces (
Data.Default.def :: State.Board.Board T.X T.Y
)
) . deconstruct where
slave nPieces [] = nPieces
slave nPieces forest = minimum $ map (
\Data.Tree.Node {
Data.Tree.rootLabel = (qualifiedMove, _),
Data.Tree.subForest = subForest
} -> slave (
Attribute.MoveType.nPiecesMutator (Component.QualifiedMove.getMoveType qualifiedMove) nPieces
) subForest
) forest
count :: QualifiedMoveForest x y -> (Model.Game.NGames, Component.Move.NMoves)
count = slave . deconstruct where
slave = Data.List.foldl' (
\(nGames, nMoves) Data.Tree.Node {
Data.Tree.rootLabel = (_, maybeOnymousResult),
Data.Tree.subForest = forest
} -> let
acc@(nGames', nMoves') = (
(+ nGames) . (
if Data.Maybe.isJust maybeOnymousResult
then succ
else id
) *** (+ nMoves) . succ
) $ slave forest
in nGames' `seq` nMoves' `seq` acc
) (0, 0)
toGameTree :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
) => QualifiedMoveForest x y -> Model.GameTree.GameTree x y
{-# SPECIALISE toGameTree :: QualifiedMoveForest T.X T.Y -> Model.GameTree.GameTree T.X T.Y #-}
toGameTree MkQualifiedMoveForest { deconstruct = qualifiedMoveForest } = Model.GameTree.fromBareGameTree Data.Tree.Node {
Data.Tree.rootLabel = initialGame,
Data.Tree.subForest = map (slave initialGame) qualifiedMoveForest
} where
initialGame = Data.Default.def
slave game Data.Tree.Node {
Data.Tree.rootLabel = (qualifiedMove, _),
Data.Tree.subForest = qualifiedMoveForest'
} = Data.Tree.Node {
Data.Tree.rootLabel = game',
Data.Tree.subForest = map (slave game') qualifiedMoveForest'
} where
game' = Model.Game.applyQualifiedMove qualifiedMove game