content: module Update where
  
  import Control.Monad.Trans.State
  import qualified Data.HashMap.Strict as HM
  import qualified Data.Set as Set
  import Game hiding (Model)
  import Game.Prelude
  import Graphics.Gloss.Interface.IO.Game
    (Event(..), Key(..), KeyState(..), MouseButton(..), SpecialKey(..))
  import Layout
  import Model
  
  data Input
    = UserEvent Event
    | OpponentOrders Player Orders
    | TimePassed Float
  
  -- | __Player guide previous__: 'Base'
  --
  -- Use left click to select, right click to move. In detail, to:
  --
  -- === Select a base
  --
  -- 1. Left click it.
  --
  -- === Change what a friendly base is building
  --
  -- 1. Select it.
  -- 2. Click one of the production options on the right (e.g. @Corvette@).
  --
  -- === Move a single ship
  --
  -- 1. Select the base where it is.
  -- 2. Select the ship by left clicking it from the list on the right.
  -- 3. Right click the destination base.
  --
  -- === Move all the friendly ships at a base
  --
  -- 1. Select the base.
  -- 2. Right click the destination base.
  -- (Note that this doesn't move @Station@s. They're so slow you'll usually
  -- want to leave them behind).
  --
  -- This ends the essential section of the player guide. If you want to learn
  -- the rest by experimentation you can start playing now. If not read on.
  --
  -- __Next__: 'Game.Update.Diplomacy.diplomacy'
  update :: Input -> Model -> Model
  update i m =
    case i of
      UserEvent event ->
        execState (userInput event) m
  
      TimePassed _ ->
        tickOrTock m
  
      OpponentOrders p o ->
        execState checkForNewTurn (m & modelOpponentOrdersL %~ HM.insert p o)
  
  --------------------------------------------------------------------------------
  -- * Time passed
  --------------------------------------------------------------------------------
  
  tickOrTock :: Model -> Model
  tickOrTock =
    modelTickL %~ next
    where
      next :: Tick -> Tick
      next = \case
        Tick -> Tock
        Tock -> Tick
  
  --------------------------------------------------------------------------------
  -- * checkForNewTurn
  --
  -- Called after we receive opponent orders or end our own turn.
  --------------------------------------------------------------------------------
  
  checkForNewTurn :: State Model ()
  checkForNewTurn = do
    b <- isTurnOver
    when b updateTurnEnd
    where
      isTurnOver :: State Model Bool
      isTurnOver = do
        playerTurnEnded <- use modelTurnEndedL
        opOrders <- use modelOpponentOrdersL
        pure $ playerTurnEnded && HM.size opOrders > 0
  
  updateTurnEnd :: State Model ()
  updateTurnEnd = do
    currentPlayer <- use modelWhoAmIL
    allOrders <- do
      playerOrders <- use modelOrdersL
      opponentOrders <- use modelOpponentOrdersL
      pure $ opponentOrders <> HM.singleton currentPlayer playerOrders
  
    modelGameL %= Game.update allOrders
  
    lastTurnLog <- use (modelGameL . modelLogL)
    modelPopupL .= map (uncurry CombatLog) (hmToList (logCombat lastTurnLog))
  
    modelOrdersL .= mempty
    modelOpponentOrdersL .= mempty
    resetPaginations
    perhapsClearSelection
    modelTurnEndedL .= False
  
  resetPaginations :: State Model ()
  resetPaginations =
    modelPlaceScrollL .= mempty
  
  perhapsClearSelection :: State Model ()
  perhapsClearSelection = do
    currentPlayer <- use modelWhoAmIL
    ships <- use (modelGameL . modelShipsL)
    selected <- use modelSelectionL
    case selected of
      SelectionNone ->
        pure ()
  
      SelectionPlace _ ->
        pure ()
  
      SelectionShip shipId -> do
        let ship = getShip shipId ships
        case shipLocation ship of
          Destroyed ->
            modelSelectionL .= SelectionNone
  
          InFlight{} ->
            when (shipPlayer ship /= currentPlayer) $
              modelSelectionL .= SelectionNone
  
          AtPlace _ ->
            pure ()
  
  --------------------------------------------------------------------------------
  -- * Result check
  --------------------------------------------------------------------------------
  
  data UpdateResult
    = Normal
    | PlayerEndedTurn Orders
    | Exit
  
  updateResult :: Model -> Model -> UpdateResult
  updateResult oldModel m
    | modelExit m = Exit
    | playerEndedTurn = PlayerEndedTurn (modelOrders oldModel)
    | otherwise = Normal
    where
      playerEndedTurn :: Bool
      playerEndedTurn =
           (not (modelTurnEnded oldModel) && modelTurnEnded m)
        || turnRolledForward
  
      turnRolledForward :: Bool
      turnRolledForward =
        let f = modelTurn . modelGame
        in f oldModel /= f m
  
  --------------------------------------------------------------------------------
  -- * User input
  --------------------------------------------------------------------------------
  
  userInput :: Event -> State Model ()
  userInput event =
    case event of
      EventKey (SpecialKey KeyEsc) Down _ _ ->
        modelExitL .= True
  
      _ -> do
        model <- get
        case modelPopup model of
          [] ->
            updateNormal event
  
          popup:rest ->
            updatePopup event popup rest
  
  updatePopup :: Event -> CombatLog -> [CombatLog] -> State Model ()
  updatePopup event _ rest = do
    case event of
      EventKey (SpecialKey KeyEnter) Down _ _ ->
        modelPopupL .= rest
  
      _ ->
        pure ()
  
  updateNormal :: Event -> State Model ()
  updateNormal event = do
    model <- get
    let currentPlayer = modelWhoAmI model
        places = modelPlaces (modelGame model)
        ships = modelShips (modelGame model)
  
        whenCanMove :: State Model () -> State Model ()
        whenCanMove move =
          case outcome (modelGame model) of
            Victor _ ->
              pure ()
  
            AllDefeated ->
              pure ()
  
            Ongoing ->
              when (not (modelTurnEnded model)) move
  
    case event of
      EventMotion (x,y) -> do
        let
          screenPoint :: ScreenPoint
          screenPoint =
            ScreenPoint x y
  
        modelCursorDotL .= screenPoint
  
        dragToPan <- use modelDragToPanL
        case dragToPan of
          NotDragging ->
            pure ()
  
          PossibleDragStart initial@(ScreenPoint initialX initialY) -> do
            if distance (x,y) (initialX,initialY) < 10
              then
                pure ()
  
              else do
                modelDragToPanL .= Dragging initial
  
          Dragging old -> do
            BoardPoint oldX oldY <- runScreenToBoardPoint old
            BoardPoint newX newY <- runScreenToBoardPoint screenPoint
            let f :: BoardPoint -> BoardPoint
                f (BoardPoint panX panY) =
                  BoardPoint (panX + (oldX - newX)) (panY + (oldY - newY))
            modelPanL %= f
            modelDragToPanL .= Dragging screenPoint
  
      EventResize (width, height) ->
        modelScreenSizeL .= Box (realToFrac width) (realToFrac height)
  
      -- The meaning of latestMouseX, latestMouseY needs to be documented in gloss.
      EventKey key upOrDown _ (latestMouseX, latestMouseY) -> do
        let
          screenPoint :: ScreenPoint
          screenPoint =
            ScreenPoint latestMouseX latestMouseY
  
        case upOrDown of
          Up ->
            case key of
              MouseButton LeftButton -> do
                dragToPan <- use modelDragToPanL
                case dragToPan of
                  -- We didn't move very much while we had the mouse down
                  -- so we weren't dragging at all! Instead we were
                  -- left clicking to clear the selection.
                  PossibleDragStart _ ->
                    modelSelectionL .= SelectionNone
  
                  NotDragging ->
                    pure ()
  
                  Dragging _ ->
                    pure ()
  
                modelDragToPanL .= NotDragging
  
              _ ->
                pure ()
  
          Down ->
            case key of
              Char 'c' ->
                modelPanL .= BoardPoint 0 0
  
              Char '=' -> do
                currentZoom <- use modelZoomL
                when (currentZoom /= maxZoom) (panTowardsCursor screenPoint)
  
                modelZoomL %= zoomIn
  
              Char '-' ->
                modelZoomL %= zoomOut
  
              Char _ ->
                pure ()
  
              SpecialKey KeySpace ->
                whenCanMove $ do
                  modelTurnEndedL .= True
                  checkForNewTurn
  
              SpecialKey _ ->
                pure ()
  
              MouseButton WheelUp -> do
                currentZoom <- use modelZoomL
                when (currentZoom /= maxZoom) (panTowardsCursor screenPoint)
  
                modelZoomL %= zoomIn
  
              MouseButton WheelDown ->
                modelZoomL %= zoomOut
  
              MouseButton button -> do
                case interpretMouseMsg model screenPoint button of
                  BaseSelect placeId ->
                    modelSelectionL .= SelectionPlace placeId
  
                  SwitchBuilding placeId buildOrder ->
                    whenCanMove $ do
                      let place = getPlace placeId places
                      case placeType place of
                        Ruin ->
                          pure ()
  
                        PBase base ->
                          when (baseOwner base == PlayerOwner currentPlayer) $ do
                            if baseBuilding base == buildOrder
                              then
                                modelOrdersL . ordersBuildL %= HM.delete placeId
                              else
                                modelOrdersL . ordersBuildL %= HM.insert placeId buildOrder
  
                  ShipSelect shipId ->
                    modelSelectionL .= SelectionShip shipId
  
                  ShipsEmbark shipIds _ destId ->
                    whenCanMove $
                      for_ shipIds $ \shipId -> do
                        let ship = getShip shipId ships
                        when (shipPlayer ship == currentPlayer) $
                          modelOrdersL . ordersEmbarkL %= HM.insert shipId destId
  
                  PreviousPage placeId ->
                    modelPlaceScrollL %= HM.adjust (subtract 1) placeId
  
                  NextPage placeId ->
                    modelPlaceScrollL %= HM.insertWith (+) placeId 1
  
                  EmptySpace ->
                    modelDragToPanL .= PossibleDragStart screenPoint
  
                  NoOp ->
                    pure ()
  
  -- | Do this softly so zooming in doesn't fling us away from the map.
  --
  -- This calculation isn't needed by View so no need to move it into Msg.
  panTowardsCursor :: ScreenPoint -> State Model ()
  panTowardsCursor screenPoint = do
    uiPoint <- runScreenToUIPoint screenPoint
    case uiPoint of
      Left _ -> pure ()
      Right selectedPoint ->
        modelPanL %= panTowards selectedPoint
    where
      panTowards :: BoardPoint -> BoardPoint -> BoardPoint
      panTowards selectedPoint panPoint@(BoardPoint px py) =
        let
          sel = fromBoardPoint selectedPoint
          pan = fromBoardPoint panPoint
          d = distance sel pan
          speed = d / 3
          (x,y) = deltas (angleBetweenPoints pan sel) speed
        in BoardPoint (px + x) (py + y)
  
  runScreenToUIPoint :: ScreenPoint -> State Model (Either HudPoint BoardPoint)
  runScreenToUIPoint screenPoint = do
    screenSize <- use modelScreenSizeL
    pan <- use modelPanL
    zoom <- use modelZoomL
    pure (screenToUIPoint screenSize zoom pan screenPoint)
  
  runScreenToBoardPoint :: ScreenPoint -> State Model BoardPoint
  runScreenToBoardPoint screenPoint = do
    pan <- use modelPanL
    zoom <- use modelZoomL
    pure (screenToBoardPoint zoom pan screenPoint)
  
  data Msg
    = BaseSelect PlaceId
    | SwitchBuilding PlaceId BuildOrder
    | ShipSelect ShipId
    | ShipsEmbark (Set ShipId) PlaceId PlaceId -- ^ ships, departure, destination
    | PreviousPage PlaceId
    | NextPage PlaceId
    | EmptySpace
    | NoOp
  
  interpretMouseMsg :: Model -> ScreenPoint -> MouseButton -> Msg
  interpretMouseMsg m@Model{..} screenPoint button = do
    case button of
      LeftButton ->
        handleLeftButton
  
      RightButton ->
        fromMaybe NoOp handleRightButton
  
      _ ->
        NoOp
  
    where
      mChosenItem :: Maybe Item
      mChosenItem =
        uiLayoutLookup m screenPoint
  
      handleLeftButton :: Msg
      handleLeftButton =
        case mChosenItem of
          Nothing ->
            EmptySpace
  
          Just chosenItem ->
            case chosenItem of
              HudItem item _ ->
                case item of
                  ItemHudShip id _ ->
                    ShipSelect id
  
                  ItemBuildButton placeId buildOrder clickable _ ->
                    case clickable of
                      NotClickable ->
                        NoOp
  
                      Clickable ->
                        SwitchBuilding placeId buildOrder
  
                  ItemPreviousPage placeId _ ->
                    PreviousPage placeId
  
                  ItemNextPage placeId _ ->
                    NextPage placeId
  
              HudItself mPlaceId _ _ ->
                maybe NoOp BaseSelect mPlaceId
  
              BoardItem item _ ->
                case item of
                  ItemBase id _ ->
                    BaseSelect id
  
                  ItemShip id _ ->
                    ShipSelect id
  
      handleRightButton :: Maybe Msg
      handleRightButton = do
        chosenItem <- mChosenItem
        case chosenItem of
          BoardItem (ItemBase chosenId _) _ -> do
            case modelSelection of
              SelectionNone ->
                Nothing
  
              SelectionPlace placeId ->
                let ships = shipsAtPlace placeId (modelShips modelGame)
                    shipsLessStations = HM.filter (\s -> shipType s /= Station) ships
                    ids = Set.fromList (HM.keys shipsLessStations)
                in Just (ShipsEmbark ids placeId chosenId)
  
              SelectionShip shipId ->
                let ship = getShip shipId (modelShips modelGame)
                in case shipLocation ship of
                  InFlight{} ->
                    Nothing
  
                  Destroyed ->
                    Nothing
  
                  AtPlace departureId ->
                    Just (ShipsEmbark (Set.singleton shipId) departureId chosenId)
  
          _ ->
            Nothing
  