module Game.Mastermind.HTML (
complete,
generate,
main,
) where
import qualified Game.Mastermind.CodeSet.Tree as CodeSetTree
import qualified Game.Mastermind.CodeSet as CodeSet
import qualified Game.Mastermind as MM
import Game.Utility (readMaybe, nullToMaybe, randomSelect, )
import Text.Html((<<), (+++), concatHtml, toHtml)
import qualified Text.Html as Html
import qualified Network.CGI as CGI
import qualified Data.List as List
import qualified Data.List.HT as ListHT
import qualified Data.NonEmpty.Set as NonEmptySet
import qualified Data.NonEmpty as NonEmpty
import Data.Foldable (fold, foldMap)
import Data.NonEmpty ((!:))
import Data.Tuple.HT (mapPair, )
import Data.Maybe.HT (toMaybe, )
import qualified Control.Monad.Trans.State as MS
import Control.Monad (liftM2, replicateM, )
import qualified System.Random as Rnd
labelAnchor :: String -> Html.Html -> Html.Html
labelAnchor ref label = Html.anchor label Html.! [Html.href ref]
concatMapHtml :: (a -> Html.Html) -> [a] -> Html.Html
concatMapHtml f = concatHtml . map f
maybeSingle :: (a -> b) -> Maybe a -> [b]
maybeSingle f = foldMap (\a -> [f a])
type Move = (String, MM.Eval)
type Config = (Int, NonEmpty.T [] Char, Int, Maybe [Move], Maybe String)
evaluation :: MM.Eval -> Html.Html
evaluation (MM.Eval rightPlaces rightSymbols) =
(Html.table $
Html.tr $
concatMapHtml
(\color -> (Html.td << Html.spaceHtml) Html.! [Html.bgcolor color]) $
replicate rightPlaces Html.black ++
replicate rightSymbols Html.white)
Html.! [Html.border 2]
state ::
Config ->
Maybe (CodeSetTree.T Char) ->
Maybe String ->
Html.Html
state (width, alphabet, seed, mMoves, mAttempt) mRemaining mCheck =
let moves = fold mMoves
select name options =
(Html.select $ concatMapHtml (Html.option <<) options)
Html.! [Html.name name]
verify code eval =
case mCheck of
Nothing -> []
Just check ->
let shouldBeEval = MM.evaluate check code
in if shouldBeEval == eval
then [toHtml " "]
else [toHtml "sollte sein: ", evaluation shouldBeEval]
won =
not (null moves) &&
case last moves of
(_, MM.Eval rightPlaces _) -> rightPlaces == width
codeTds = map ((Html.! [Html.align "center"]) . Html.td . toHtml)
in Html.center $
(Html.! [Html.action "Mastermind"]) $
Html.form $ concatHtml $
[Html.hidden "width" (show width),
Html.hidden "alphabet" (NonEmpty.flatten alphabet),
Html.hidden "seed" (show seed),
Html.hidden "moves" (unwords $ map formatMove moves)]
++
maybeSingle (Html.hidden "attempt") mAttempt
++
[(Html.table $
concatMapHtml Html.tr $
zipWith
(\n row -> (Html.th << (show n ++ ".")) +++ row)
[(0::Int)..] $
flip map moves (\(code, eval) ->
concatHtml $
codeTds code ++
map Html.td (evaluation eval : verify code eval))
++
if won || maybe False CodeSet.null mRemaining
then []
else [
maybe
(Html.td (Html.textfield "attempt" Html.!
[Html.maxlength width]) Html.! [Html.colspan width]
+++
Html.td (Html.submit "" "abschicken"))
(\attempt ->
concatHtml $
codeTds attempt ++
let numbers = map show [0..width]
in [Html.td $ Html.simpleTable [] []
[[evaluation (MM.Eval 1 0),
select "rightplaces" numbers,
Html.spaceHtml,
evaluation (MM.Eval 0 1),
select "rightsymbols" numbers,
Html.spaceHtml,
Html.submit "" "bewerten"]]])
mAttempt])
]
++
(case mRemaining of
Nothing -> []
Just remaining ->
[case CodeSet.size remaining of
0 ->
toHtml "Die Bewertungen sind widerspr\252chlich."
+++
Html.br
+++
toHtml "Welchen Code meinten Sie? "
+++
Html.textfield "check" Html.! [Html.maxlength width]
+++
Html.submit "" "pr\252fen"
1 -> toHtml "Dies ist die einzige verbleibende M\246glichkeit."
n ->
toHtml
("Es bleiben noch " ++ show n ++
" M\246glichkeiten. Hier eine kleine Auswahl:")
+++
(Html.ordList $ take 10 $ CodeSet.flatten remaining)])
++
(if won
then [Html.br, Html.bold << "R\228tsel gel\246st!"]
else [])
game :: String -> Html.Html
game s =
case parseQuery s of
Just ((width, symbols, seed, mMoves, mAttempt), mCheck) ->
case (mMoves,mAttempt) of
(Just moves, Nothing) ->
let alphabet = NonEmptySet.fromList symbols
remaining =
CodeSet.compress $
CodeSet.intersections $
CodeSet.cube alphabet width !:
map (uncurry (MM.matching
(NonEmptySet.flatten alphabet))) moves
(attempt,newSeed) =
maybe
(Nothing, seed)
(mapPair (Just, fst . Rnd.random)) $
MS.runStateT
(MM.mixedRandomizedAttempt width remaining)
(Rnd.mkStdGen seed)
in state
(width, symbols, newSeed, Just moves, attempt)
(Just remaining)
mCheck
_ ->
let code =
MS.evalState
(replicateM width $ randomSelect $
NonEmpty.flatten symbols)
(Rnd.mkStdGen seed)
in state
(width, symbols, seed,
Just $
fold mMoves ++
maybeSingle
(\attempt -> (attempt, MM.evaluate code attempt))
mAttempt,
Nothing)
Nothing
mCheck
Nothing ->
toHtml $
"Mit dem Spielstand " ++ show s ++ " kann ich nichts anfangen."
start :: Int -> Html.Html
start seed =
toHtml "Es r\228t" +++
Html.simpleTable [] []
(ListHT.outerProduct
(\(alphabet,typ,widthName) (computerAttempts,player) ->
toHtml ("der "++player++" "++typ++" mit ")
+++
(concatHtml $ List.intersperse (toHtml ", ") $
map
(\width ->
labelAnchor
("Mastermind?"++
formatQuery
(width, alphabet, seed,
toMaybe computerAttempts [], Nothing))
<< show width)
[3..7])
+++
toHtml (" "++widthName++"."))
[('0'!:['1'..'9'], "Zahlen", "Stellen"),
('a'!:['b'..'z'], "W\246rter", "Buchstaben")]
[(False,"Mensch"),(True,"Computer")])
Html.! [Html.border 2]
complete :: Html.Html -> Html.Html
complete body =
Html.header (Html.thetitle << "Mastermind") +++
Html.body body +++
Html.br +++ labelAnchor "Mastermind" << "Noch einmal von vorne!"
generate :: Maybe String -> IO Html.Html
generate = maybe (fmap start Rnd.randomIO) (return . game)
formatQuery :: Config -> String
formatQuery (width, alphabet, seed, mMoves, mAttempt) =
CGI.formEncode $
("width", show width) :
("alphabet", NonEmpty.flatten alphabet) :
("seed", show seed) :
(case mAttempt of
Nothing -> []
Just attempt -> [("attempt", attempt)]) ++
(case mMoves of
Nothing -> []
Just moves -> [("moves", unwords $ map formatMove moves)]) ++
[]
formatMove :: (String, MM.Eval) -> String
formatMove (code, MM.Eval rightPlaces rightSymbols) =
code ++ "-" ++ show rightPlaces ++ "-" ++ show rightSymbols
parseQuery :: String -> Maybe (Config, Maybe String)
parseQuery query =
let pairs = CGI.formDecode query
in do width <- readMaybe =<< List.lookup "width" pairs
alphabet <- NonEmpty.fetch =<< List.lookup "alphabet" pairs
seed <- readMaybe =<< List.lookup "seed" pairs
mMoves <-
maybe (Just Nothing)
(fmap Just .
mapM (\moveText ->
case ListHT.chop ('-' ==) moveText of
[code,rightPlacesText,rightSymbolsText] ->
fmap ((,) code) $
liftM2 MM.Eval
(readMaybe rightPlacesText)
(readMaybe rightSymbolsText)
_ -> Nothing)
.
words) $
List.lookup "moves" pairs
let mAttempt0 = List.lookup "attempt" pairs
mRightPlaces = fmap readMaybe $ List.lookup "rightplaces" pairs
mRightSymbols = fmap readMaybe $ List.lookup "rightsymbols" pairs
(moves,mAttempt) <-
case mMoves of
Nothing -> Just (Nothing, Nothing)
Just moves0 ->
case liftM2 (,) mAttempt0 $
liftM2 (,) mRightPlaces mRightSymbols of
Just (move, mEval) ->
fmap (\eval ->
(Just $ moves0 ++ [(move,eval)], Nothing)) $
uncurry (liftM2 MM.Eval) mEval
Nothing -> Just (Just moves0, mAttempt0)
return ((width, alphabet, seed, moves, mAttempt),
List.lookup "check" pairs)
main :: IO ()
main =
putStr . Html.renderHtml . complete =<< generate . nullToMaybe =<< getLine