scores.hs

-- hplayground by mark mann

-- identify user and record round by round results

{-# LANGUAGE  DeriveDataTypeable, FlexibleInstances, UndecidableInstances #-}
module Main where
import Haste
import Haste.Foreign
import Haste.LocalStorage
import Haste.JSON (JSON(..))
import Haste.Serialize

import Haste.Graphics.Canvas
import Haste.HPlay.View
import Haste.HPlay.Cell as Cell
import Control.Applicative
import Control.Monad
import Control.Monad.IO.Class
import Data.Monoid
import Data.Typeable
import Prelude hiding (div,all,id,print,getChar, putStr, putStrLn,getLine)
import qualified Data.Map as V
import Data.Maybe
import Data.List(isInfixOf)
import qualified Data.Map as M


main= runBody $ do  -- PerchM monad
      h1 ! style "text-align:left" $ "Scoreboard"

    ++> do   -- Widget monad
    (table ! style "border-collapse:collapse"
            <<<(tr ! style "vertical-align:top"
                 <<< ( tds <<< sumRecursive "player0"
                 <|>   tds <<< formWidget)
            <|> tr ! style "vertical-align:top"
                 <<< ( tds <<< sumRecursive "player1"
                 <|>   tds <<< formWidget)
            <|> tr ! style "vertical-align:top"
                 <<< ( tds <<< sumRecursive "playger2"
                 <|>   tds <<< formWidget)
            <|> tr ! style "vertical-align:top"
                 <<< ( tds <<< sumRecursive "player3"
                 <|>   tds <<< formWidget)
             <|> tr ! style "vertical-align:top"
                 <<< ( tds <<< sumRecursive "player4"
                 <|>   tds <<< formWidget)
            <|> tr ! style "vertical-align:top"
                 <<< ( tds <<< sumRecursive "player5"
                 <|>   tds <<< formWidget)
            <|> tr ! style "vertical-align:top"
                 <<< ( tds <<< sumRecursive "player6"
                 <|>   tds <<< formWidget)
               ))

        <++  b << "thanks for keeping score!"
   where
   tds= td ! style "padding:15px;border-style:dotted"




getNumber :: String -> Int -> Widget Int
getNumber player i= do

        mt <- liftIO $ getItem player
        xs <- case mt of
          Left _ ->  liftIO ( setItem player (M.toList (M.empty :: M.Map Int Int))) >> return M.empty
          Right ts -> return (M.fromList ts)
        case M.lookup i xs  of
          Nothing -> empty
          Just x  -> return x

addNumber player i x= liftIO $ do
        mt <- getItem player 
        xs <- case mt of
          Left _ ->  liftIO ( setItem player (M.toList (M.empty :: M.Map Int Int))) >> return M.empty
          Right ts -> return (M.fromList ts)
        setItem player $ M.toList (M.insert i x xs :: M.Map Int Int)

cell player i=  do
     stored <- Just <$> getNumber player i <|> return Nothing
     r' <- inputInt stored `fire` OnKeyUp <|> fromM stored
     addNumber player i r'
     return r'
     where
     fromM Nothing = empty
     fromM (Just x) = return x
     
-- Don't be scared by the operators:
-- <|> is the Alternantive combinator, to combine Widget() entries
-- and the <<< combinator simply encloses a widget within a HTML tag.
-- ++> prepend HTML to a widget
-- <++ postpend it


sumRecursive :: String -> Widget ()
sumRecursive player= p  "Player Per Round Results" ++> sumr 0 0
  where
  sumr i r=do
    r' <- cell player i
    if r'== 0
      then  br ++> fromStr "result: " ++>  b (show r) ++> noWidget
      else do
        b (show $ r+r') ++> br ++> return ()
        sumr (i+1) (r+r')

formWidget=  center <<< do -- PerchM monad
      (n,s) <- (,) <$> p << "Who are you? "
                   ++> getString Nothing
                   <*> getString Nothing  <++ br
                   <** submitButton "ok" `fire` OnClick <++ br

      flag <- b << "Are You " ++> getRadio[radiob "a pro?",radiob "beetlebaum?"] <++ br

      r<- case flag of
         "a pro?" -> Left  <$> b << "do you enjoy being a pro? "
                              ++> getBool True "yes" "no"
                              <** submitButton "ok" `fire` OnClick <++ br

         "beetlebaum?"-> Right <$> b << "are you beetlebaum "
                              ++> getRadio[radiob "sometimes"
                                          ,radiob "always"]

      p << ("You are "++n++" "++s)

        ++> case r of
             Left fl ->   p << ("You are a " ++ show fl ++ " pro, and you enjoy it")
                            ++> noWidget

             Right stu -> p << ("You are beetlebaum " ++ stu)
                            ++> noWidget

  where
  hint s= [("placeholder",s)]
  radiob s n=  wlabel  (fromStr s) $ setRadioActive s n