content: {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE GADTs #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE ParallelListComp #-}
  {-# LANGUAGE PatternGuards #-}
  {-# LANGUAGE PatternSynonyms #-}
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE ViewPatterns #-}
  {-# OPTIONS_GHC -Wno-unticked-promoted-constructors
                  -Wno-name-shadowing
                  -Wno-star-is-type
    #-}
  
  {-
    Copyright 2020 The CodeWorld Authors. All rights reserved.
  
    Licensed under the Apache License, Version 2.0 (the "License");
    you may not use this file except in compliance with the License.
    You may obtain a copy of the License at
  
        http://www.apache.org/licenses/LICENSE-2.0
  
    Unless required by applicable law or agreed to in writing, software
    distributed under the License is distributed on an "AS IS" BASIS,
    WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
    See the License for the specific language governing permissions and
    limitations under the License.
  -}
  module CodeWorld.CollaborationUI
    ( UIState,
      SetupPhase (..),
      Step (..),
      initial,
      step,
      event,
      picture,
      startWaiting,
      updatePlayers,
    )
  where
  
  import CodeWorld.Color
  import CodeWorld.Event
  import CodeWorld.Picture
  import Data.Char
  import qualified Data.Text as T
  import Data.Text (Text)
  
  -- | The enumeration type contains all the high-level states that the game UI
  -- can be in. It is used as a type-index to 'UIState' to ensure that the UI
  -- state matches the abstract state.
  --
  -- The possible UI-triggered transitions of this state are described by
  -- 'Step'.
  data SetupPhase
    = SMain
    | SConnect
    | SWait
  
  -- | Possible steps taken from a given setup phase
  data family Step :: (SetupPhase -> *) -> SetupPhase -> *
  
  data instance Step f SMain
    = ContinueMain (f SMain)
    | Create (f SConnect)
    | Join Text (f SConnect)
  
  data instance Step f SConnect
    = ContinueConnect (f SConnect)
    | CancelConnect (f SMain)
  
  data instance Step f SWait
    = ContinueWait (f SWait)
    | CancelWait (f SMain)
  
  -- | The UI state, indexed by the 'SetupPhase'
  data UIState (s :: SetupPhase) where
    MainMenu :: Double -> Point -> UIState SMain
    Joining :: Double -> Point -> Text -> UIState SMain
    Connecting :: Double -> Point -> UIState SConnect
    Waiting ::
      Double ->
      Point ->
      Text ->
      Int ->
      Int {- numPlayers :: -} ->
      {- present -}
      UIState SWait
  
  continueUIState :: UIState s -> Step UIState s
  continueUIState s@MainMenu {} = ContinueMain s
  continueUIState s@Joining {} = ContinueMain s
  continueUIState s@Connecting {} = ContinueConnect s
  continueUIState s@Waiting {} = ContinueWait s
  
  time :: UIState s -> Double
  time (MainMenu t _) = t
  time (Joining t _ _) = t
  time (Connecting t _) = t
  time (Waiting t _ _ _ _) = t
  
  mousePos :: UIState s -> Point
  mousePos (MainMenu _ p) = p
  mousePos (Joining _ p _) = p
  mousePos (Connecting _ p) = p
  mousePos (Waiting _ p _ _ _) = p
  
  -- Takes an absolute time, not a delta. A bit easier.
  step :: Double -> UIState s -> UIState s
  step t (MainMenu _ p) = MainMenu t p
  step t (Joining _ p c) = Joining t p c
  step t (Connecting _ p) = Connecting t p
  step t (Waiting _ p c n m) = Waiting t p c n m
  
  setMousePos :: Point -> UIState s -> UIState s
  setMousePos p (MainMenu t _) = MainMenu t p
  setMousePos p (Joining t _ c) = Joining t p c
  setMousePos p (Connecting t _) = Connecting t p
  setMousePos p (Waiting t _ c n m) = Waiting t p c n m
  
  initial :: UIState SMain
  initial = MainMenu 0 (0, 0)
  
  startWaiting :: Text -> UIState a -> UIState SWait
  startWaiting code s = Waiting (time s) (mousePos s) code 0 0
  
  updatePlayers :: Int -> Int -> UIState SWait -> UIState SWait
  updatePlayers n m (Waiting time mousePos code _ _) =
    Waiting time mousePos code n m
  
  -- | Handling a UI event. May change the phase.
  event :: Event -> UIState s -> Step UIState s
  event (PointerMovement p) s = continueUIState (setMousePos p s)
  event CreateClick (MainMenu t p) = Create (Connecting t p)
  event JoinClick (MainMenu t p) = ContinueMain (Joining t p "")
  event (LetterPress k) (Joining t p code)
    | T.length code < 4 = ContinueMain (Joining t p (code <> k))
  event BackSpace (Joining t p code)
    | T.length code > 0 = ContinueMain (Joining t p (T.init code))
  event ConnectClick (Joining t p code)
    | T.length code == 4 = Join code (Connecting t p)
  event CancelClick (Joining t p _) = ContinueMain (MainMenu t p)
  event CancelClick (Connecting t p) = CancelConnect (MainMenu t p)
  event CancelClick (Waiting t p _ _ _) = CancelWait (MainMenu t p)
  event _ s = continueUIState s
  
  pattern CreateClick :: Event
  pattern CreateClick <-
    PointerPress (inButton 0 1.5 8 2 -> True)
  
  pattern JoinClick :: Event
  pattern JoinClick <-
    PointerPress (inButton 0 (-1.5) 8 2 -> True)
  
  pattern ConnectClick :: Event
  pattern ConnectClick <-
    PointerPress (inButton 0 (-3.0) 8 2 -> True)
  
  pattern LetterPress :: Text -> Event
  pattern LetterPress c <- (isLetterPress -> Just c)
  
  pattern BackSpace :: Event
  pattern BackSpace <- KeyPress "Backspace"
  
  pattern CancelClick :: Event
  pattern CancelClick <- (isCancelClick -> True)
  
  isLetterPress :: Event -> Maybe Text
  isLetterPress (KeyPress k)
    | T.length k == 1,
      isLetter (T.head k) =
      Just (T.toUpper k)
  isLetterPress _ = Nothing
  
  isCancelClick :: Event -> Bool
  isCancelClick (KeyPress "Esc") = True
  isCancelClick (PointerPress point) = inButton 0 (-3) 8 2 point
  isCancelClick _ = False
  
  picture :: UIState s -> Picture
  picture (MainMenu time mousePos) =
    button "New" (dull green) 0 1.5 8 2 mousePos
      & button "Join" (dull green) 0 (-1.5) 8 2 mousePos
      & connectScreen "Main Menu" time
  picture (Joining time mousePos code) =
    translated 0 2 (lettering "Enter the game key:") & letterBoxes white code
      & ( if T.length code < 4
            then button "Cancel" (dull yellow) 0 (-3) 8 2 mousePos
            else button "Join" (dull green) 0 (-3) 8 2 mousePos
        )
      & connectScreen "Join Game" time
  picture (Connecting time mousePos) =
    button "Cancel" (dull yellow) 0 (-3) 8 2 mousePos
      & connectScreen "Connecting..." time
  picture (Waiting time mousePos code numPlayers present) =
    translated 0 2 (lettering "Share this key with other players:")
      & translated 0 4 (playerDots numPlayers present)
      & letterBoxes (HSL 0 0 0.8) code
      & button "Cancel" (dull yellow) 0 (-3) 8 2 mousePos
      & connectScreen "Waiting" time
  
  letterBoxes :: Color -> Text -> Picture
  letterBoxes color txt =
    pictures
      [ translated x 0 (letterBox color (T.singleton c))
        | c <- pad 4 ' ' (take 4 (T.unpack txt))
        | x <- [-3, -1, 1, 3]
      ]
  
  letterBox :: Color -> Text -> Picture
  letterBox c t =
    thickRectangle 0.1 1.5 1.5 & lettering t & colored c (solidRectangle 1.5 1.5)
  
  pad :: Int -> a -> [a] -> [a]
  pad 0 _ xs = xs
  pad n v (x : xs) = x : pad (n - 1) v xs
  pad n v [] = v : pad (n - 1) v []
  
  inButton :: Double -> Double -> Double -> Double -> Point -> Bool
  inButton x y w h (mx, my) =
    mx >= x - w / 2 && mx <= x + w / 2 && my >= y - h / 2 && my <= y + h / 2
  
  button ::
    Text -> Color -> Double -> Double -> Double -> Double -> Point -> Picture
  button txt btnColor x y w h (mx, my) =
    translated x y $
      colored white (styledLettering Plain SansSerif txt)
        & colored color (roundRect w h)
    where
      color
        | inButton x y w h (mx, my) = btnColor
        | otherwise = dark btnColor
  
  roundRect :: Double -> Double -> Picture
  roundRect w h =
    solidRectangle w (h - 0.5) & solidRectangle (w - 0.5) h
      & pictures
        [ translated x y (solidCircle 0.25)
          | x <- [- w / 2 + 0.25, w / 2 - 0.25],
            y <- [- h / 2 + 0.25, h / 2 - 0.25]
        ]
  
  playerDots :: Int -> Int -> Picture
  playerDots n m
    | n > 8 = lettering $ T.pack $ show m ++ " / " ++ show n
  playerDots n m =
    pictures
      [ translated
          (size * fromIntegral i - size * fromIntegral n / 2)
          0
          (dot (i <= m))
        | i <- [1 .. n]
      ]
    where
      dot True = solidCircle (0.4 * size)
      dot False = circle (0.4 * size)
      size = 1
  
  connectScreen :: Text -> Double -> Picture
  connectScreen hdr t =
    translated 0 (-7) connectBox
      & translated 0 2.5 (colored background (solidRectangle 20 4))
      & translated 0 5 codeWorldLogo
      & colored background (solidRectangle 20 20)
    where
      connectBox =
        scaled 2 2 (lettering hdr)
          & rectangle 14 3
          & colored connectColor (solidRectangle 14 3)
      connectColor =
        let k = (1 + sin (3 * t)) / 5
         in HSL (k + 0.5) 0.8 0.7
      background = RGBA 0.85 0.86 0.9 1
  