{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE ExtendedDefaultRules       #-}
{-# LANGUAGE CPP                        #-}
module Game.Hanabi.Client where

import Game.Hanabi hiding (main, rule)
import Game.Hanabi.Msg

import           Data.Aeson   hiding (Success)
import           GHC.Generics hiding (K1)
import           Data.Bool
import qualified Data.Map as M
import qualified Data.IntMap as IM
import Data.Maybe(fromJust)

import           Miso         hiding (Fail)
import           Miso.String  (MisoString)
import qualified Miso.String  as S

#ifdef IOS
import Language.Javascript.JSaddle.WKWebView as JSaddle

runApp :: JSM () -> IO ()
runApp = JSaddle.run
#else
import Language.Javascript.JSaddle.Warp as JSaddle

runApp :: JSM () -> IO ()
runApp = JSaddle.run 8080 -- 8720
#endif

-- Miso's implementation of WebSockets uses global IORef.
-- https://github.com/dmjio/miso/blob/master/frontend-src/Miso/Subscription/WebSocket.hs

main' :: String -> IO ()
main' versionInfo = runApp $ startApp App{
    model  = Model{tboxval = Message "available", players = [0], rule = defaultRule, received = [], fullHistory = False},
    update = updateModel,
    view   = appView versionInfo,
    subs   = [ websocketSub uri protocols HandleWebSocket ],
    events = defaultEvents,
    initialAction = Id,
    -- initialAction = SendMessage $ Message "available", -- Seemingly sending as initialAction does not work, even if connect is executed before send.
    mountPoint = Nothing}
#ifdef URI
uri = URL URI
#else
-- uri = URL "ws://133.54.228.39:8720"
uri = URL "ws://localhost:8720"
#endif
protocols = Protocols []

{- At last, I chose to hide the history by default.
lenHistory = 400
-- A better approach might be
-- 1. to send the history to a separate frame after the endgame
-- 2. to memoize renderMsg
-- Also, `observe' should not send to the current player.
-}
updateModel :: Action -> Model -> Effect Action Model
updateModel (HandleWebSocket (WebSocketMessage (Message m))) model
  = noEff model{ received = {- take lenHistory $ -} memoMsg verbose model (decodeMsg m) : received model }
updateModel (SendMessage msg) model = model{fullHistory=False} <# (-- connect uri protocols >>
                                                send msg >> return Id)
updateModel (UpdateTBoxVal m) model = noEff model{ tboxval = Message m }
updateModel IncreasePlayers   model = noEff model{players = take 9 $ 0 : players model}
updateModel DecreasePlayers   model = noEff model{players = case players model of {n:ns@(_:_) -> ns; ns -> ns}}
updateModel (UpdateRule r)    model | isRuleValid r = noEff model{rule=r}
updateModel Toggle            model = noEff model{fullHistory = not $ fullHistory model}
#ifdef DEBUG
updateModel (HandleWebSocket act) model = noEff model{received = memoMsg verbose model (Str (show act)) : received model }
#endif
updateModel _ model = noEff model

instance ToJSON Message
instance FromJSON Message

newtype Message = Message MisoString
  deriving (Eq, Show, Generic)

data Action
  = HandleWebSocket (WebSocket Message)
  | SendMessage Message
  | UpdateTBoxVal MisoString
  | IncreasePlayers
  | DecreasePlayers
  | UpdateRule Rule
  | Toggle
  | Id

data Model = Model {
    tboxval :: Message
  , players :: [Int]
  , rule :: Rule
  , received :: [MsgView]
  , fullHistory :: Bool
  } deriving (Show, Eq)

-- MsgView memoizes the view of its Msg.
data MsgView = MV{theMsg :: Msg, viewMsg :: View Action}
instance Eq MsgView where
  MV m1 _ == MV m2 _ = m1 == m2
instance Show MsgView where
  showsPrec _ (MV m _) = ("(MV "++) . shows m . (')':)
    -- Also, toHtml could be used for showing viewMsg.

lenShownHistory = 10
appView :: String -> Model -> View Action
appView versionInfo mdl@Model{..} = div_ [] [
   input_  [ type_ "text", placeholder_ "You can also use your keyboard.", size_ "25", onInput UpdateTBoxVal, onEnter (SendMessage tboxval) ]
 , button_ [ onClick (SendMessage tboxval) ] [ text (S.pack "Send to the server") ]
-- x , span_ [style_ $ M.fromList [("font-size","10px")]] [text $ S.pack "(Use this line if you prefer the keyboard interface.)"]
 , span_ [style_ $ M.fromList [("font-size","10px"), ("float","right")]] [text $ S.pack $ "hanabi-dealer client "++versionInfo]
-- , hr_ []
 , div_ [style_ $ M.fromList [("clear","both")]] ((if fullHistory then id else take lenShownHistory) $ map viewMsg received)
 , div_ [] $ if null $ drop lenShownHistory received then [] else [
     hr_ []
   , input_ [ type_ "checkbox", id_ "showhist", onClick Toggle, checked_ fullHistory]
   , label_ [for_ "showhist"] [text "Show full history"]
   ]
 ]

onEnter :: Action -> Attribute Action
onEnter action = onKeyDown $ bool Id action . (== KeyCode 13)
{-
#ifdef AESON
prettyDecode :: MisoString -> MisoString
prettyDecode str = case decode $ S.fromMisoString str of Nothing  -> str
                                                         Just msg -> S.toMisoString $ encode $ prettyMsg verbose msg
#else
prettyDecode :: MisoString -> MisoString
prettyDecode str = case reads $ S.fromMisoString str of []  -> str
                                                        [(msg,_)] -> S.toMisoString $ prettyMsg verbose msg
#endif
render :: MisoString -> View Action
render str = case decode str' of Nothing  -> text $ S.fromMisoString str
                                 Just msg -> renderMsg verbose msg
   where str' = S.fromMisoString str
-}
decodeMsg :: MisoString -> Msg
#ifdef AESON
decodeMsg str = case decode $ S.fromMisoString str of Nothing  -> Str $ S.fromMisoString str
                                                      Just msg -> msg
#else
decodeMsg str = case reads $ S.fromMisoString str of []  -> Str $ S.fromMisoString str
                                                     [(msg,_)] -> msg
#endif

memoMsg :: Verbosity -> Model -> Msg -> MsgView
memoMsg v mdl msg = MV msg $ renderMsg v mdl msg

renderMsg :: Verbosity -> Model -> Msg -> View Action
renderMsg _    _ (Str xs)             = div_ [] [hr_ [], pre_ [] [ text $ S.pack xs ]]
renderMsg verb _ (WhatsUp name ps ms) = renderWhatsUp  verb name ps ms
renderMsg verb _ (WhatsUp1     p  m)  = renderWhatsUp1 verb p m
renderMsg _    _ (PrettyEndGame Nothing)     = pre_ [] [ text $ S.pack $ prettyMbEndGame Nothing]
renderMsg _    _ (PrettyEndGame (Just tup))  = renderEndGame tup -- pre_ [] [ text $ S.pack $ prettyEndGame tup]
renderMsg _    mdl (PrettyAvailable games)
  = div_ [style_ $ M.fromList [("overflow","auto")]] [
      hr_ [],
      table_ [style_ $ M.fromList [("border-style","solid"), ("clear","both"), ("float","right")]] $
           caption_ [] [text $ S.pack "Available games", button_ [onClick $ SendMessage $ Message "available"] [text $ S.pack "refresh"]] :
           tr_ [] [ th_ [solid] [text $ S.pack str] | str <- ["Game ID", "available", "total"] ] :
           map renderAvailable games,
      div_ [] [
           input_ [type_ "text", onInput (UpdateRule . head . (++[rule mdl]) . map fst . reads . S.unpack), value_ $ S.pack $ show $ rule mdl, style_ $ M.fromList [("width","70%")]],
           div_ [] [
             button_ [onClick IncreasePlayers] [text $ S.pack "+"],
             button_ [onClick DecreasePlayers] [text $ S.pack "-"],
             text $ S.pack $ show $ players mdl,
             button_ [onClick $ SendMessage $ Message $ S.pack $ "create " ++ show (rule mdl) ++ tail (init $ show $ players mdl)] [text $ S.pack "create a game"]
           ]
      ]
   ]
renderAvailable (gameid, (missing, total))
  = tr_ [onClick $ SendMessage $ Message $ S.pack $ "attend "++show gameid] [ td_ [solid] [text $ S.pack str] | str <- [show gameid, show missing, show total] ]
solid = style_ $ M.fromList [("border-style","solid")]

renderWhatsUp verb name views@(v:_) moves = div_ [] [
  hr_ [],
  text $ S.pack "Your turn.",
  hr_ [],
  renderRecentEvents (publicView v) ithPlayer views moves,
  hr_ [],
  text $ S.pack $ "Algorithm: " ++ name,
  renderPV verb v
 ]
renderWhatsUp1 :: Verbosity -> PrivateView -> Move -> View Action
renderWhatsUp1 verb v m = div_ [style_ $ M.fromList [("background-color","#555555"),("color","#000000")]] [
  hr_ [],
  renderTrial (publicView v) (const "") undefined v m,
  hr_ [],
  renderPV verb v
 ]

renderEndGame :: (EndGame, [State], [Move]) -> View Action
renderEndGame (eg,sts@(st:_),mvs)
  = div_ [] [
         hr_ [],
         renderRecentEvents (publicState st) ithPlayerFromTheLast (map Game.Hanabi.view sts) mvs,
         hr_ [],
         h1_ [style_ $ M.fromList [("background-color","#FF0000"),("color","#000000")]] [text $ S.pack $ show eg],
         hr_ [],
         renderSt ithPlayerFromTheLast st,
         hr_ []
         ]

renderTrial :: PublicInfo -> (Int -> String) -> Int -> PrivateView -> Move -> View Action
renderTrial pub ithP i v m =  div_ [] [
  text $ S.pack $ ithP i ++ " move: " ++ {- replicate (length (ithP 2) - length (ithP i)) ' ' ++ -} show m
  , case result $ publicView v of Discard c -> showResults c ", which revealed "
                                  Success c -> showResults c ", which succeeded revealing "
                                  Fail    c -> showResults c ", which failed revealing "
                                  _         -> text $ S.pack ""
  ]
  where showResults c xs = span_ [] [
            xs
--          , renderHand' verbose pub [Just c] [(Nothing,Nothing)]
          , renderCardInline verbose pub c
          , text $ S.pack "."
          ]
renderPI pub
{- This was too verbose
  = let
      showDeck 0 = "no card at the deck (the game will end in " ++ shows (fromJust $ deadline pub) " turn(s)), "
      showDeck 1 = "1 card at the deck, "
      showDeck n = shows n " cards at the deck, "
    in  "Turn "++ shows (turn pub) ": " ++ showDeck (pileNum pub) ++ shows (lives pub) " live(s) left, " ++ shows (hintTokens pub) " hint tokens;\n\n"
-}
  = let
      showDeck 0 = "Deck: 0 (" ++ shows (fromJust $ deadline pub) " turn(s) left),  "
      showDeck 1 = "Deck: 1,  "
      showDeck n = "Deck: " ++ shows n ",  "
    in div_ [] [
      text $ S.pack $ "Turn: "++ shows (turn pub) ",  " ++ showDeck (pileNum pub) ++ "Lives: " ++ shows (lives pub) ",  Hints: " ++ shows (hintTokens pub) ";",

      div_ [] [
        text $ S.pack $ "played:",
        span_ [] [ span_ [] $ text (S.pack "|") : [ renderCardInline verbose pub $ C c k | k <- [K1 .. playedMax]] | c <- [White .. Multicolor], Just playedMax <- [IM.lookup (fromEnum c) (played pub)] ],
        text $ S.pack "|"
      ],

      div_ [] [
        text $ S.pack $ "dropped: ",
        span_ [] [ span_ [] $ text (S.pack "|") : (replicate n $ renderCardInline verbose pub $ intToCard ci) | (ci,n) <- IM.toList $ discarded pub ],
        text $ S.pack "|"
      ]
     ]
renderCardInline v pub c = span_ [style_ $ M.fromList [("width","30px"),("color", colorStr $ Just $ color c),("background-color","#000000")]] [cardStr verbose pub 0 (Just c) (Nothing,Nothing)]

renderRecentEvents :: PublicInfo -> (Int -> Int -> String) -> [PrivateView] -> [Move] -> View Action
renderRecentEvents pub ithP vs@(v:_) ms = div_ [] $ reverse $ zipWith3 (renderTrial pub $ ithP nump) [pred nump, nump-2..0] vs ms
   where nump = numPlayers $ gameSpec $ publicView v


renderPV :: Verbosity -> PrivateView -> View Action
renderPV v pv@PV{publicView=pub} = div_ [] [
  renderPI pub,
  div_ [] (
--      div_ [] [text $ S.pack $ "My hand:"] :
--      renderCards v pub [ Nothing | _ <- myHand] myHand :
      renderHand v pub (const "My") 0 [ Nothing | _ <- myHand] myHand :
--                                              ++ concat [ '+':shows d "-" | d <- [0 .. pred $ length myHand] ]
      (zipWith3 (renderHand v pub (ithPlayer $ numPlayers $ gameSpec pub)) [1..] (map (map Just) $ handsPV pv) $ tail $ givenHints pub)
    )
  ]
  where myHand = head (givenHints pub)

renderSt ithP st@St{publicState=pub} = div_ [] $
  renderPI pub :
  zipWith3 (renderHand verbose pub (ithP $ numPlayers $ gameSpec pub)) [0..] (map (map Just) $ hands st) (givenHints pub)

renderHand :: Verbosity -> PublicInfo -> (Int->String) -> Int -> [Maybe Card] -> [(Maybe Color, Maybe Number)] -> View Action
renderHand v pub ithPnumP i mbcards hl = div_ [] [
  div_ [] [text $ S.pack $ ithPnumP i ++ " hand:"],
   renderHand' v pub i mbcards hl
--  renderCards v pub (map Just cards) hl
  ]
renderHand' :: Verbosity -> PublicInfo -> Int -> [Maybe Card] -> [(Maybe Color, Maybe Number)] -> View Action
renderHand' v pub pli mbcards hl = 
   table_ [style_ $ M.fromList [("border-color","#FFFFFF"), ("border-width","medium")]] [tr_ [style_ $ M.fromList [("background-color","#000000"), ("height","48px")]] (zipWith3 (renderCard v pub pli) [0..] mbcards hl)]

renderCard :: Verbosity -> PublicInfo -> Int -> Index -> Maybe Card -> (Maybe Color, Maybe Number) -> View Action
renderCard v pub pli i mbc tup@(mc,mk) = td_ [style_ $ M.fromList [("width","36px"),
                                                                   ("color", colorStr $ fmap color mbc)]] [
     maybe (button_ [ onClick (SendMessage $ Message $ S.pack $ 'p':show i) ] [ text (S.pack "play") ]) (const $ span_[][]) mbc,
     div_ [] [
        cardStr v pub pli mbc tup
     ],
     div_ [] [text $ S.pack $ if markHints v then maybe '_' (head . show) mc : [maybe '_' (head . show . fromEnum) mk] else "__" ],
     maybe (button_ [ onClick (SendMessage $ Message $ S.pack $ 'd':show i) ] [ text (S.pack "drop") ]) (const $ span_[][]) mbc
  ]
{-
renderCards :: Verbosity -> PublicInfo -> [Maybe Card] -> [(Maybe Color, Maybe Number)] -> View Action
renderCards v pub mbcs tups = table_ [style_ $ M.fromList [("border-color","#FFFFFF"),("border-width","medium")]] [
  tr_ [style_ $ M.fromList [("background-color","#000000")]]
     [
       td_ [style_ $ M.fromList [("color", colorStr $ fmap color mbc)]] [
        cardStr v pub mbc tup
        ]
     | (mbc,tup) <- zip mbcs tups
     ],
  tr_ [style_ $ M.fromList [("background-color","#000000")]]
     [
       td_ [style_ $ M.fromList [("color", colorStr $ fmap color mbc)]] [
          text $ S.pack $ if markHints v then maybe ' ' (head . show) mc : [maybe ' ' (head . show . fromEnum) mk] else ""
       ]
     | (mbc,(mc,mk)) <- zip mbcs tups
     ]
  ]
-}
-- Not sure which style is better.
#ifdef BUTTONSONCARDS
cardStr v pub pli mbc tup = case mbc of
          Nothing -> span_ [] [text $ S.pack "??"]
          Just c  -> span_ [] [
--                                    text $ S.pack $ show c
                                    button_ [onClick (SendMessage $ Message $ S.pack $ shows pli $ take 1 $ show $ color c), style] [text $ S.pack $ take 1 $ show $ color c],
                                    button_ [onClick (SendMessage $ Message $ S.pack $ shows pli $ show $ fromEnum $ number c), style][text $ S.pack $ show $ fromEnum $ number c]
                             ]
                     where style = style_ $ M.fromList [
                              ("font-weight", if markUseless v && isUseless pub c then "100"
                                              else if warnCritical v && tup==(Nothing,Nothing) && isCritical pub c then "bold" else "normal"),
                              ("font-style",  if markPlayable v && isPlayable pub c then "oblique" else "normal"), ("background-color","#000000"),("color", colorStr $ fmap color mbc)]
#else
cardStr v pub pli mbc tup = case mbc of
          Nothing -> span_ [] [text $ S.pack "??"]
          Just c  -> span_ [style_ $ M.fromList [-- ("width","30px"),
                              ("font-weight", if markUseless v && isUseless pub c then "100"
                                              else if warnCritical v && tup==(Nothing,Nothing) && isCritical pub c then "bold" else "normal"),
                              ("font-style",  if markPlayable v && isPlayable pub c then "oblique" else "normal")]] [
--                                    text $ S.pack $ show c
                                    span_ [style_ $ M.fromList [("font-size","20px")],
                                              onClick (SendMessage $ Message $ S.pack $ shows pli $ take 1 $ show $ color c)] [text $ S.pack $ take 1 $ show $ color c],
                                    span_ [style_ $ M.fromList [("font-size","20px")],
                                              onClick (SendMessage $ Message $ S.pack $ shows pli $ show $ fromEnum $ number c)][text $ S.pack $ show $ fromEnum $ number c]
                             ]
#endif
colorStr Nothing       = "#00FFFF"
colorStr (Just White)  = "#FFFFFF"
colorStr (Just Yellow) = "#FFFF00"
colorStr (Just Red)    = "#FF4444"
colorStr (Just Green)  = "#44FF44"
colorStr (Just Blue)   = "#8888FF"
colorStr (Just Multicolor) = "#FF00FF"