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, nonEmptySetToList, )
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.Set as Set
import Data.NonEmpty ((!:))
import Data.Tuple.HT (mapPair, )
import Data.Maybe.HT (toMaybe, )
import qualified Control.Monad.Trans.State as State
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]
type Move = (String, MM.Eval)
type Config = (Int, NonEmptySet.T Char, Int, Maybe [Move], Maybe String)
evaluation :: MM.Eval -> Html.Html
evaluation (MM.Eval rightPlaces rightSymbols) =
(Html.table $
Html.tr $ concatHtml $
replicate rightPlaces
((Html.td << Html.spaceHtml) Html.! [Html.bgcolor Html.black]) ++
replicate rightSymbols
((Html.td << Html.spaceHtml) Html.! [Html.bgcolor 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 = maybe [] id mMoves
select name options =
(Html.select $ concatHtml $
map (Html.option . toHtml) 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:" +++
Html.spaceHtml +++
evaluation shouldBeEval]
won =
not (null moves) &&
case last moves of
(_, MM.Eval rightPlaces _) -> rightPlaces == width
in Html.center $
(Html.! [Html.action "Mastermind"]) $
Html.form $ concatHtml $
[Html.hidden "width" (show width),
Html.hidden "alphabet" (nonEmptySetToList alphabet),
Html.hidden "seed" (show seed),
Html.hidden "moves" (unwords $ map formatMove moves)]
++
maybe [] (\attempt -> [Html.hidden "attempt" attempt]) mAttempt
++
[(Html.table $
concatHtml $ map Html.tr $
zipWith (\n row -> Html.th (toHtml (show n ++ ".")) +++ row) [(0::Int)..] $
flip map moves (\(code, eval) ->
concatHtml $ map Html.td $
map toHtml code ++
[evaluation eval] ++
verify code eval)
++
if won || maybe False (null . CodeSet.flatten) mRemaining
then []
else [
maybe
(Html.td (Html.textfield "attempt" Html.!
[Html.maxlength width]) Html.! [Html.colspan width]
+++
Html.td (Html.submit "" "abschicken"))
(\attempt ->
concatHtml $ map Html.td $
map toHtml attempt ++
let numbers = map show [0..width]
in [concatHtml
[select "rightplaces" numbers,
Html.spaceHtml,
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 $ Html.toHtml "R\228tsel gel\246st!"]
else [])
game :: String -> Html.Html
game s =
case parseQuery s of
Just ((width, alphabet, seed, mMoves, mAttempt), mCheck) ->
case (mMoves,mAttempt) of
(Just moves, Nothing) ->
let 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)) $
State.runStateT
(MM.mixedRandomizedAttempt width remaining)
(Rnd.mkStdGen seed)
in state
(width, alphabet, newSeed, Just moves, attempt)
(Just remaining)
mCheck
_ ->
let code =
State.evalState
(replicateM width
(randomSelect (nonEmptySetToList alphabet)))
(Rnd.mkStdGen seed)
in state
(width, alphabet, seed,
Just $ maybe [] id mMoves ++
maybe [] (\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 [] []
(map (\(alphabet,typ) ->
map (\(computerAttempts,player) ->
labelAnchor
("Mastermind?"++
formatQuery
(4, NonEmptySet.fromList alphabet, seed,
toMaybe computerAttempts [], Nothing))
<< ("der "++player++" "++typ++"."))
[(False,"Mensch"),(True,"Computer")])
[('0'!:['1'..'9'], "Zahlen"),('a'!:['b'..'z'], "W\246rter")])
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", nonEmptySetToList 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 <-
NonEmptySet.fetch . Set.fromList =<< 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