scoreboard.hs

-- hplayground by Alberto modified by mark mann
-- keeps score for up to nine players for many rounds


-- 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
import Data.IORef
import System.IO.Unsafe


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

    div ! id "global" $ noHtml
    table ! style "border-collapse:collapse" $ do
      thead $ do
          th ! style "width:30%" $ "Player name"
          th ! style "width:70%" $ "Scores"
      tbody $ do
        mconcat[
            tr ! style "vertical-align:top" $ do
                   tds $ div ! id ("player" ++ show i ++ "name") $ noHtml
                   tds $ div ! id ("player"++ show i) $ noHtml
                   | i<-[1..10]]
                   
  mconcat [formWidget ("player" ++ show i) <|>
           sumRecursive ("player" ++ show i)
          | i <- [1..10]]

 <** (wraw $  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 ! atr "size" "5" <|> 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

global= unsafePerformIO $ newIORef (0,0)

sumRecursive :: String -> Widget ()
sumRecursive player= at player  Insert $ do
  wraw $ div ! id (player ++"scores") $ noHtml
  sumRecursive' player

sumRecursive' player= 
  at (player ++ "scores") Insert $ p  "Player Per Round Results" ++> sumr 0 0
  where
  sumr i r=do
    r' <- cell player i
    liftIO $ atomicModifyIORef global $ \(s,n) ->  ((s+r',n+1),())
    wraw $ do 
      let (h,t)= break (=='.') $ show((fromIntegral $ r+ r')/ fromIntegral (i+1))

      b $ " total=" ++ show (r+r') 
      b $ " mean="++ h ++ take 2 t
      br 

    at "global" Insert $ do
        (s,n) <- liftIO $ readIORef global
        let (h,t)= break (=='.') $ show(fromIntegral s/fromIntegral n)
        wraw $ p $ "global mean= " ++ h ++ take 2 t

    sumr (i+1) (r+r')

formWidget player  = at (player ++ "name") Insert $ do
  wraw $ center $  div ! id (player ++ "name") $ noHtml
  formWidget' player
  where 
  formWidget' player= at (player ++ "name") Insert $ do
    r <- liftIO $ getItem $ player ++ "name"
    case r of
      Left _ -> do 
                   name <- askName player
                   liftIO $ setItem (player++ "name") name
      Right name -> (wraw $ p << (name :: String))
                           <|> reset player
  
  
  askName player= do
      (n,s) <- (,) <$> p << "Player name? "
                   ++> getString Nothing
                   <*> getString Nothing  <++ br
                   <** submitButton "ok" `fire` OnClick <++ br

      
     
      at (player ++ "name") Insert $ do
                        let name= n++" "++s
                        (wraw $ p << name) <|> reset player
                        return name 

   

  reset player= do
    wbutton "reset" "reset"
    liftIO $ removeItem player
    liftIO $ removeItem $ player ++ "name"
    formWidget' player <|> sumRecursive' player