module Game.Mastermind.HTML 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, )
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.Set as Set
import qualified Control.Monad.Trans.State as State
import Control.Monad (liftM2, replicateM, )
import Data.Tuple.HT (mapPair, )
import qualified System.Random as Rnd
labelAnchor :: String -> Html.Html -> Html.Html
labelAnchor ref label =
Html.anchor label Html.! [Html.href ref]
relHeight, relWidth :: Int -> Html.HtmlAttr
relHeight r = Html.strAttr "HEIGHT" (show r ++ "%")
relWidth r = Html.strAttr "WIDTH" (show r ++ "%")
type Move = (String, MM.Eval)
type Config = (Int, Set.Set 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" (Set.toAscList 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.remaining alphabet)) moves
(attempt,newSeed) =
maybe
(Nothing, seed)
(mapPair (Just, fst . Rnd.random)) $
State.runStateT
(MM.mixedRandomizedAttempt width alphabet remaining)
(Rnd.mkStdGen seed)
in state
(width, alphabet, newSeed, Just moves, attempt)
(Just remaining)
mCheck
_ ->
let code =
State.evalState
(replicateM width
(MM.randomSelect (Set.toList 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, Set.fromList alphabet, seed,
if computerAttempts then Just [] else Nothing, Nothing))
<< ("der "++player++" "++typ++"."))
[(False,"Mensch"),(True,"Computer")])
[(['0'..'9'], "Zahlen"),(['a'..'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", Set.toAscList 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 <- fmap 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