{-# 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 :: forall (s :: SetupPhase). UIState s -> Step UIState s
continueUIState s :: UIState s
s@MainMenu {} = forall (f :: SetupPhase -> *). f 'SMain -> Step f 'SMain
ContinueMain UIState s
s
continueUIState s :: UIState s
s@Joining {} = forall (f :: SetupPhase -> *). f 'SMain -> Step f 'SMain
ContinueMain UIState s
s
continueUIState s :: UIState s
s@Connecting {} = forall (f :: SetupPhase -> *). f 'SConnect -> Step f 'SConnect
ContinueConnect UIState s
s
continueUIState s :: UIState s
s@Waiting {} = forall (f :: SetupPhase -> *). f 'SWait -> Step f 'SWait
ContinueWait UIState s
s

time :: UIState s -> Double
time :: forall (s :: SetupPhase). UIState s -> Double
time (MainMenu Double
t Point
_) = Double
t
time (Joining Double
t Point
_ Text
_) = Double
t
time (Connecting Double
t Point
_) = Double
t
time (Waiting Double
t Point
_ Text
_ Int
_ Int
_) = Double
t

mousePos :: UIState s -> Point
mousePos :: forall (s :: SetupPhase). UIState s -> Point
mousePos (MainMenu Double
_ Point
p) = Point
p
mousePos (Joining Double
_ Point
p Text
_) = Point
p
mousePos (Connecting Double
_ Point
p) = Point
p
mousePos (Waiting Double
_ Point
p Text
_ Int
_ Int
_) = Point
p

-- Takes an absolute time, not a delta. A bit easier.
step :: Double -> UIState s -> UIState s
step :: forall (s :: SetupPhase). Double -> UIState s -> UIState s
step Double
t (MainMenu Double
_ Point
p) = Double -> Point -> UIState 'SMain
MainMenu Double
t Point
p
step Double
t (Joining Double
_ Point
p Text
c) = Double -> Point -> Text -> UIState 'SMain
Joining Double
t Point
p Text
c
step Double
t (Connecting Double
_ Point
p) = Double -> Point -> UIState 'SConnect
Connecting Double
t Point
p
step Double
t (Waiting Double
_ Point
p Text
c Int
n Int
m) = Double -> Point -> Text -> Int -> Int -> UIState 'SWait
Waiting Double
t Point
p Text
c Int
n Int
m

setMousePos :: Point -> UIState s -> UIState s
setMousePos :: forall (s :: SetupPhase). Point -> UIState s -> UIState s
setMousePos Point
p (MainMenu Double
t Point
_) = Double -> Point -> UIState 'SMain
MainMenu Double
t Point
p
setMousePos Point
p (Joining Double
t Point
_ Text
c) = Double -> Point -> Text -> UIState 'SMain
Joining Double
t Point
p Text
c
setMousePos Point
p (Connecting Double
t Point
_) = Double -> Point -> UIState 'SConnect
Connecting Double
t Point
p
setMousePos Point
p (Waiting Double
t Point
_ Text
c Int
n Int
m) = Double -> Point -> Text -> Int -> Int -> UIState 'SWait
Waiting Double
t Point
p Text
c Int
n Int
m

initial :: UIState SMain
initial :: UIState 'SMain
initial = Double -> Point -> UIState 'SMain
MainMenu Double
0 (Double
0, Double
0)

startWaiting :: Text -> UIState a -> UIState SWait
startWaiting :: forall (a :: SetupPhase). Text -> UIState a -> UIState 'SWait
startWaiting Text
code UIState a
s = Double -> Point -> Text -> Int -> Int -> UIState 'SWait
Waiting (forall (s :: SetupPhase). UIState s -> Double
time UIState a
s) (forall (s :: SetupPhase). UIState s -> Point
mousePos UIState a
s) Text
code Int
0 Int
0

updatePlayers :: Int -> Int -> UIState SWait -> UIState SWait
updatePlayers :: Int -> Int -> UIState 'SWait -> UIState 'SWait
updatePlayers Int
n Int
m (Waiting Double
time Point
mousePos Text
code Int
_ Int
_) =
  Double -> Point -> Text -> Int -> Int -> UIState 'SWait
Waiting Double
time Point
mousePos Text
code Int
n Int
m

-- | Handling a UI event. May change the phase.
event :: Event -> UIState s -> Step UIState s
event :: forall (s :: SetupPhase). Event -> UIState s -> Step UIState s
event (PointerMovement Point
p) UIState s
s = forall (s :: SetupPhase). UIState s -> Step UIState s
continueUIState (forall (s :: SetupPhase). Point -> UIState s -> UIState s
setMousePos Point
p UIState s
s)
event Event
CreateClick (MainMenu Double
t Point
p) = forall (f :: SetupPhase -> *). f 'SConnect -> Step f 'SMain
Create (Double -> Point -> UIState 'SConnect
Connecting Double
t Point
p)
event Event
JoinClick (MainMenu Double
t Point
p) = forall (f :: SetupPhase -> *). f 'SMain -> Step f 'SMain
ContinueMain (Double -> Point -> Text -> UIState 'SMain
Joining Double
t Point
p Text
"")
event (LetterPress Text
k) (Joining Double
t Point
p Text
code)
  | Text -> Int
T.length Text
code forall a. Ord a => a -> a -> Bool
< Int
4 = forall (f :: SetupPhase -> *). f 'SMain -> Step f 'SMain
ContinueMain (Double -> Point -> Text -> UIState 'SMain
Joining Double
t Point
p (Text
code forall a. Semigroup a => a -> a -> a
<> Text
k))
event Event
BackSpace (Joining Double
t Point
p Text
code)
  | Text -> Int
T.length Text
code forall a. Ord a => a -> a -> Bool
> Int
0 = forall (f :: SetupPhase -> *). f 'SMain -> Step f 'SMain
ContinueMain (Double -> Point -> Text -> UIState 'SMain
Joining Double
t Point
p (Text -> Text
T.init Text
code))
event Event
ConnectClick (Joining Double
t Point
p Text
code)
  | Text -> Int
T.length Text
code forall a. Eq a => a -> a -> Bool
== Int
4 = forall (f :: SetupPhase -> *). Text -> f 'SConnect -> Step f 'SMain
Join Text
code (Double -> Point -> UIState 'SConnect
Connecting Double
t Point
p)
event Event
CancelClick (Joining Double
t Point
p Text
_) = forall (f :: SetupPhase -> *). f 'SMain -> Step f 'SMain
ContinueMain (Double -> Point -> UIState 'SMain
MainMenu Double
t Point
p)
event Event
CancelClick (Connecting Double
t Point
p) = forall (f :: SetupPhase -> *). f 'SMain -> Step f 'SConnect
CancelConnect (Double -> Point -> UIState 'SMain
MainMenu Double
t Point
p)
event Event
CancelClick (Waiting Double
t Point
p Text
_ Int
_ Int
_) = forall (f :: SetupPhase -> *). f 'SMain -> Step f 'SWait
CancelWait (Double -> Point -> UIState 'SMain
MainMenu Double
t Point
p)
event Event
_ UIState s
s = forall (s :: SetupPhase). UIState s -> Step UIState s
continueUIState UIState s
s

pattern CreateClick :: Event
pattern $mCreateClick :: forall {r}. Event -> ((# #) -> r) -> ((# #) -> r) -> r
CreateClick <-
  PointerPress (inButton 0 1.5 8 2 -> True)

pattern JoinClick :: Event
pattern $mJoinClick :: forall {r}. Event -> ((# #) -> r) -> ((# #) -> r) -> r
JoinClick <-
  PointerPress (inButton 0 (-1.5) 8 2 -> True)

pattern ConnectClick :: Event
pattern $mConnectClick :: forall {r}. Event -> ((# #) -> r) -> ((# #) -> r) -> r
ConnectClick <-
  PointerPress (inButton 0 (-3.0) 8 2 -> True)

pattern LetterPress :: Text -> Event
pattern $mLetterPress :: forall {r}. Event -> (Text -> r) -> ((# #) -> r) -> r
LetterPress c <- (isLetterPress -> Just c)

pattern BackSpace :: Event
pattern $mBackSpace :: forall {r}. Event -> ((# #) -> r) -> ((# #) -> r) -> r
BackSpace <- KeyPress "Backspace"

pattern CancelClick :: Event
pattern $mCancelClick :: forall {r}. Event -> ((# #) -> r) -> ((# #) -> r) -> r
CancelClick <- (isCancelClick -> True)

isLetterPress :: Event -> Maybe Text
isLetterPress :: Event -> Maybe Text
isLetterPress (KeyPress Text
k)
  | Text -> Int
T.length Text
k forall a. Eq a => a -> a -> Bool
== Int
1,
    Char -> Bool
isLetter (Text -> Char
T.head Text
k) =
    forall a. a -> Maybe a
Just (Text -> Text
T.toUpper Text
k)
isLetterPress Event
_ = forall a. Maybe a
Nothing

isCancelClick :: Event -> Bool
isCancelClick :: Event -> Bool
isCancelClick (KeyPress Text
"Esc") = Bool
True
isCancelClick (PointerPress Point
point) = Double -> Double -> Double -> Double -> Point -> Bool
inButton Double
0 (-Double
3) Double
8 Double
2 Point
point
isCancelClick Event
_ = Bool
False

picture :: UIState s -> Picture
picture :: forall (s :: SetupPhase). UIState s -> Picture
picture (MainMenu Double
time Point
mousePos) =
  Text
-> Color
-> Double
-> Double
-> Double
-> Double
-> Point
-> Picture
button Text
"New" (Color -> Color
dull Color
green) Double
0 Double
1.5 Double
8 Double
2 Point
mousePos
    HasCallStack => Picture -> Picture -> Picture
& Text
-> Color
-> Double
-> Double
-> Double
-> Double
-> Point
-> Picture
button Text
"Join" (Color -> Color
dull Color
green) Double
0 (-Double
1.5) Double
8 Double
2 Point
mousePos
    HasCallStack => Picture -> Picture -> Picture
& Text -> Double -> Picture
connectScreen Text
"Main Menu" Double
time
picture (Joining Double
time Point
mousePos Text
code) =
  HasCallStack => Double -> Double -> Picture -> Picture
translated Double
0 Double
2 (HasCallStack => Text -> Picture
lettering Text
"Enter the game key:") HasCallStack => Picture -> Picture -> Picture
& Color -> Text -> Picture
letterBoxes Color
white Text
code
    HasCallStack => Picture -> Picture -> Picture
& ( if Text -> Int
T.length Text
code forall a. Ord a => a -> a -> Bool
< Int
4
          then Text
-> Color
-> Double
-> Double
-> Double
-> Double
-> Point
-> Picture
button Text
"Cancel" (Color -> Color
dull Color
yellow) Double
0 (-Double
3) Double
8 Double
2 Point
mousePos
          else Text
-> Color
-> Double
-> Double
-> Double
-> Double
-> Point
-> Picture
button Text
"Join" (Color -> Color
dull Color
green) Double
0 (-Double
3) Double
8 Double
2 Point
mousePos
      )
    HasCallStack => Picture -> Picture -> Picture
& Text -> Double -> Picture
connectScreen Text
"Join Game" Double
time
picture (Connecting Double
time Point
mousePos) =
  Text
-> Color
-> Double
-> Double
-> Double
-> Double
-> Point
-> Picture
button Text
"Cancel" (Color -> Color
dull Color
yellow) Double
0 (-Double
3) Double
8 Double
2 Point
mousePos
    HasCallStack => Picture -> Picture -> Picture
& Text -> Double -> Picture
connectScreen Text
"Connecting..." Double
time
picture (Waiting Double
time Point
mousePos Text
code Int
numPlayers Int
present) =
  HasCallStack => Double -> Double -> Picture -> Picture
translated Double
0 Double
2 (HasCallStack => Text -> Picture
lettering Text
"Share this key with other players:")
    HasCallStack => Picture -> Picture -> Picture
& HasCallStack => Double -> Double -> Picture -> Picture
translated Double
0 Double
4 (Int -> Int -> Picture
playerDots Int
numPlayers Int
present)
    HasCallStack => Picture -> Picture -> Picture
& Color -> Text -> Picture
letterBoxes (Double -> Double -> Double -> Color
HSL Double
0 Double
0 Double
0.8) Text
code
    HasCallStack => Picture -> Picture -> Picture
& Text
-> Color
-> Double
-> Double
-> Double
-> Double
-> Point
-> Picture
button Text
"Cancel" (Color -> Color
dull Color
yellow) Double
0 (-Double
3) Double
8 Double
2 Point
mousePos
    HasCallStack => Picture -> Picture -> Picture
& Text -> Double -> Picture
connectScreen Text
"Waiting" Double
time

letterBoxes :: Color -> Text -> Picture
letterBoxes :: Color -> Text -> Picture
letterBoxes Color
color Text
txt =
  HasCallStack => [Picture] -> Picture
pictures
    [ HasCallStack => Double -> Double -> Picture -> Picture
translated Double
x Double
0 (Color -> Text -> Picture
letterBox Color
color (Char -> Text
T.singleton Char
c))
      | Char
c <- forall a. Int -> a -> [a] -> [a]
pad Int
4 Char
' ' (forall a. Int -> [a] -> [a]
take Int
4 (Text -> [Char]
T.unpack Text
txt))
      | Double
x <- [-Double
3, -Double
1, Double
1, Double
3]
    ]

letterBox :: Color -> Text -> Picture
letterBox :: Color -> Text -> Picture
letterBox Color
c Text
t =
  HasCallStack => Double -> Double -> Double -> Picture
thickRectangle Double
0.1 Double
1.5 Double
1.5 HasCallStack => Picture -> Picture -> Picture
& HasCallStack => Text -> Picture
lettering Text
t HasCallStack => Picture -> Picture -> Picture
& HasCallStack => Color -> Picture -> Picture
colored Color
c (HasCallStack => Double -> Double -> Picture
solidRectangle Double
1.5 Double
1.5)

pad :: Int -> a -> [a] -> [a]
pad :: forall a. Int -> a -> [a] -> [a]
pad Int
0 a
_ [a]
xs = [a]
xs
pad Int
n a
v (a
x : [a]
xs) = a
x forall a. a -> [a] -> [a]
: forall a. Int -> a -> [a] -> [a]
pad (Int
n forall a. Num a => a -> a -> a
- Int
1) a
v [a]
xs
pad Int
n a
v [] = a
v forall a. a -> [a] -> [a]
: forall a. Int -> a -> [a] -> [a]
pad (Int
n forall a. Num a => a -> a -> a
- Int
1) a
v []

inButton :: Double -> Double -> Double -> Double -> Point -> Bool
inButton :: Double -> Double -> Double -> Double -> Point -> Bool
inButton Double
x Double
y Double
w Double
h (Double
mx, Double
my) =
  Double
mx forall a. Ord a => a -> a -> Bool
>= Double
x forall a. Num a => a -> a -> a
- Double
w forall a. Fractional a => a -> a -> a
/ Double
2 Bool -> Bool -> Bool
&& Double
mx forall a. Ord a => a -> a -> Bool
<= Double
x forall a. Num a => a -> a -> a
+ Double
w forall a. Fractional a => a -> a -> a
/ Double
2 Bool -> Bool -> Bool
&& Double
my forall a. Ord a => a -> a -> Bool
>= Double
y forall a. Num a => a -> a -> a
- Double
h forall a. Fractional a => a -> a -> a
/ Double
2 Bool -> Bool -> Bool
&& Double
my forall a. Ord a => a -> a -> Bool
<= Double
y forall a. Num a => a -> a -> a
+ Double
h forall a. Fractional a => a -> a -> a
/ Double
2

button ::
  Text -> Color -> Double -> Double -> Double -> Double -> Point -> Picture
button :: Text
-> Color
-> Double
-> Double
-> Double
-> Double
-> Point
-> Picture
button Text
txt Color
btnColor Double
x Double
y Double
w Double
h (Double
mx, Double
my) =
  HasCallStack => Double -> Double -> Picture -> Picture
translated Double
x Double
y forall a b. (a -> b) -> a -> b
$
    HasCallStack => Color -> Picture -> Picture
colored Color
white (HasCallStack => TextStyle -> Font -> Text -> Picture
styledLettering TextStyle
Plain Font
SansSerif Text
txt)
      HasCallStack => Picture -> Picture -> Picture
& HasCallStack => Color -> Picture -> Picture
colored Color
color (Double -> Double -> Picture
roundRect Double
w Double
h)
  where
    color :: Color
color
      | Double -> Double -> Double -> Double -> Point -> Bool
inButton Double
x Double
y Double
w Double
h (Double
mx, Double
my) = Color
btnColor
      | Bool
otherwise = Color -> Color
dark Color
btnColor

roundRect :: Double -> Double -> Picture
roundRect :: Double -> Double -> Picture
roundRect Double
w Double
h =
  HasCallStack => Double -> Double -> Picture
solidRectangle Double
w (Double
h forall a. Num a => a -> a -> a
- Double
0.5) HasCallStack => Picture -> Picture -> Picture
& HasCallStack => Double -> Double -> Picture
solidRectangle (Double
w forall a. Num a => a -> a -> a
- Double
0.5) Double
h
    HasCallStack => Picture -> Picture -> Picture
& HasCallStack => [Picture] -> Picture
pictures
      [ HasCallStack => Double -> Double -> Picture -> Picture
translated Double
x Double
y (HasCallStack => Double -> Picture
solidCircle Double
0.25)
        | Double
x <- [- Double
w forall a. Fractional a => a -> a -> a
/ Double
2 forall a. Num a => a -> a -> a
+ Double
0.25, Double
w forall a. Fractional a => a -> a -> a
/ Double
2 forall a. Num a => a -> a -> a
- Double
0.25],
          Double
y <- [- Double
h forall a. Fractional a => a -> a -> a
/ Double
2 forall a. Num a => a -> a -> a
+ Double
0.25, Double
h forall a. Fractional a => a -> a -> a
/ Double
2 forall a. Num a => a -> a -> a
- Double
0.25]
      ]

playerDots :: Int -> Int -> Picture
playerDots :: Int -> Int -> Picture
playerDots Int
n Int
m
  | Int
n forall a. Ord a => a -> a -> Bool
> Int
8 = HasCallStack => Text -> Picture
lettering forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Int
m forall a. [a] -> [a] -> [a]
++ [Char]
" / " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
n
playerDots Int
n Int
m =
  HasCallStack => [Picture] -> Picture
pictures
    [ HasCallStack => Double -> Double -> Picture -> Picture
translated
        (Double
size forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i forall a. Num a => a -> a -> a
- Double
size forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n forall a. Fractional a => a -> a -> a
/ Double
2)
        Double
0
        (Bool -> Picture
dot (Int
i forall a. Ord a => a -> a -> Bool
<= Int
m))
      | Int
i <- [Int
1 .. Int
n]
    ]
  where
    dot :: Bool -> Picture
dot Bool
True = HasCallStack => Double -> Picture
solidCircle (Double
0.4 forall a. Num a => a -> a -> a
* Double
size)
    dot Bool
False = HasCallStack => Double -> Picture
circle (Double
0.4 forall a. Num a => a -> a -> a
* Double
size)
    size :: Double
size = Double
1

connectScreen :: Text -> Double -> Picture
connectScreen :: Text -> Double -> Picture
connectScreen Text
hdr Double
t =
  HasCallStack => Double -> Double -> Picture -> Picture
translated Double
0 (-Double
7) Picture
connectBox
    HasCallStack => Picture -> Picture -> Picture
& HasCallStack => Double -> Double -> Picture -> Picture
translated Double
0 Double
2.5 (HasCallStack => Color -> Picture -> Picture
colored Color
background (HasCallStack => Double -> Double -> Picture
solidRectangle Double
20 Double
4))
    HasCallStack => Picture -> Picture -> Picture
& HasCallStack => Double -> Double -> Picture -> Picture
translated Double
0 Double
5 HasCallStack => Picture
codeWorldLogo
    HasCallStack => Picture -> Picture -> Picture
& HasCallStack => Color -> Picture -> Picture
colored Color
background (HasCallStack => Double -> Double -> Picture
solidRectangle Double
20 Double
20)
  where
    connectBox :: Picture
connectBox =
      HasCallStack => Double -> Double -> Picture -> Picture
scaled Double
2 Double
2 (HasCallStack => Text -> Picture
lettering Text
hdr)
        HasCallStack => Picture -> Picture -> Picture
& HasCallStack => Double -> Double -> Picture
rectangle Double
14 Double
3
        HasCallStack => Picture -> Picture -> Picture
& HasCallStack => Color -> Picture -> Picture
colored Color
connectColor (HasCallStack => Double -> Double -> Picture
solidRectangle Double
14 Double
3)
    connectColor :: Color
connectColor =
      let k :: Double
k = (Double
1 forall a. Num a => a -> a -> a
+ forall a. Floating a => a -> a
sin (Double
3 forall a. Num a => a -> a -> a
* Double
t)) forall a. Fractional a => a -> a -> a
/ Double
5
       in Double -> Double -> Double -> Color
HSL (Double
k forall a. Num a => a -> a -> a
+ Double
0.5) Double
0.8 Double
0.7
    background :: Color
background = Double -> Double -> Double -> Double -> Color
RGBA Double
0.85 Double
0.86 Double
0.9 Double
1