{- | Input and output for Game.Mastermind -} 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]) -- Html.! [Html.border 2] ] ++ (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!" -- need Maybe String in order to distinguish between "?" and "" 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