DeviceOutput.hs

-- | A graphical user interface for the game.
--
-- It consists of three parts.
--
--  - Rendering context
--  - Initialization
--  - Rendering of game states
--
-- The rendering context is used for showing game states on the screen.
-- In SDL2 (which is used in this game) this is a renderer and a window.
--
-- The initialization creates a window that can be seen on the screen and
-- returns the associated rendering context.
--
-- Rendering includes the visualization and sound/music.
--
-- The game state is turned into a background color and visual elements
-- ('visualRepresentation'). The visual representation is then displayed
-- ('display'').
--
-- For the level playing status, the visual elements are the fields of the
-- grid.
--
-- Recently, there is only one type of visual element ('VElement') that is used
-- to define fields with their color, size and position and is displayed as
-- circles ('displayVElement').
--
-- This game does not have sound/music (yet).
module DeviceOutput where

-- External imports
import           Control.Monad   (void)
import           Data.Int        (Int16, Int32)
import           Data.List       (transpose)
import qualified Data.Text       as T (pack)
import           Foreign.C.Types (CInt (CInt))
import           SDL             (InitFlag (InitVideo), Renderer, V2 (V2),
                                  V4 (V4), Window, createSoftwareRenderer,
                                  createWindow, defaultWindow, getWindowSurface,
                                  getWindowSurface, initialize, showWindow,
                                  surfaceFillRect, updateWindowSurface,
                                  windowInitialSize)
import           SDL.Primitive   (fillCircle)

-- Internal imports
import Constants (Color, caption, defaultBG, screenMarginWH, screenWH)
import GameState (GameState, GameStatus (LevelPlaying), gameGrid, gameInfo,
                  gameLevel, gameStatus)
import Levels    (LevelSpec, background, fieldColor, levels)
import Objects   (Field, Grid, fieldId, findPosition)

-- * Rendering context

-- | The renderer and the window as rendering context.
type RenderingCtx = (Renderer, Window)

-- | Return the renderer of a rendering context.
ctxRenderer :: RenderingCtx -> Renderer
ctxRenderer (r, _w) = r

-- | Return the window of a rendering context.
ctxWindow :: RenderingCtx -> Window
ctxWindow (_r, w) = w

-- * Initialization

-- | Initializing the graphical user interface.
initializeGUI :: IO RenderingCtx
initializeGUI = do
  SDL.initialize [InitVideo]
  window <- SDL.createWindow (T.pack caption) SDL.defaultWindow {SDL.windowInitialSize = V2 screenWH screenWH }
  screenSurface <- SDL.getWindowSurface window
  renderer <- SDL.createSoftwareRenderer screenSurface
  return (renderer, window)

-- * Rendering

-- | Render the game state.

-- If you wonder where the arguments are, search for `eta conversion`.
render :: GameState -> RenderingCtx -> IO ()
render = display -- Audio can be added here.

-- | Display the game state.
display :: GameState -> RenderingCtx -> IO ()
display gs ctx = do
  let vR = visualRepresentation gs
  display' vR ctx

-- | Display a background color and a set of elements.
display':: (Color, [VElement])
       -> RenderingCtx
       -> IO ()
display' (bgColor, vElements) ctx = do

  let window = ctxWindow ctx
  screenSurface <- SDL.getWindowSurface window
  SDL.showWindow window

  let (bgR, bgB, bgG, bgA) = bgColor
  SDL.surfaceFillRect screenSurface Nothing (V4 bgR bgB bgG bgA)

  displayVElements vElements ctx

  SDL.updateWindowSurface window

-- | Display elements as circles.
displayVElements :: [VElement] -> RenderingCtx -> IO ()
displayVElements ves ctx = mapM_ (`displayVElement` ctx) ves

-- | Display one visual element as a circle.
displayVElement :: VElement -> RenderingCtx -> IO ()
displayVElement vElement ctx = do
  let renderer     = ctxRenderer ctx

      (r, g, b, a) = vElementColor vElement
      pos          = vElementPosition vElement
      (w, _h)      = vElementSize vElement
      (x', y', r') = centerCor pos w

  void $ fillCircle renderer (V2 (toCInt x') (toCInt y')) (toCInt r') (V4 r g b a)
  where
    -- | Center coordinates in a squared field.
    -- Given the x and y coordinate of the left upper corner of a field
    -- and its size, return the coordinates of the center and the halved
    -- field size.
    centerCor :: ScreenPosition -> Int -> (Int, Int, Int)
    centerCor (x, y) fsize = (x + fsize', y + fsize', fsize')
      where
        fsize' = fsize `div` 2

-- ** Visual representation of game states

-- | A visual representation of the game state as tuple of a background
-- color and multiple visual elements.
visualRepresentation :: GameState -> (Color, [VElement])
visualRepresentation gs =
  case gameStatus $ gameInfo gs of
    LevelPlaying -> visualRepresentationLevelPlaying gs
    _            -> (defaultBG,[]) -- Add more game states.

-- | A visual representation of the game state, when the game is in the
-- 'LevelPlaying' state, as tuple of a background color and multiple visual
-- elements.
visualRepresentationLevelPlaying :: GameState -> (Color, [VElement])
visualRepresentationLevelPlaying gs = (bgColor, vElements)
  where
    lvlSpec   = levels !! gameLevel (gameInfo gs)
    bgColor   = background lvlSpec
    grid      = gameGrid gs
    fldSize   = gridFieldSize grid
    fldPoss   = gridFieldsAbsPositions grid
    vElements = visualRepresentationGrid lvlSpec fldSize fldPoss

-- | A visual representation of the game grid, given the fields with their
-- positions, a level specification and a field size, as a list of visual elements.
visualRepresentationGrid :: LevelSpec -> Size -> [(Field, Position)] -> [VElement]
visualRepresentationGrid lvlSpec fldSize = map visualRepresentationField
  where
    visualRepresentationField (field, position) =
      (fieldColor lvlSpec (fieldId field), fldSize, position)

-- *** Visual properties of grids and fields

-- | Return for every field in a grid the position of the left upper corner
--   of the field on the screen.
gridFieldsAbsPositions :: Grid -> [(Field, ScreenPosition)]
gridFieldsAbsPositions grid = gridFieldsAbsPositions' (gridFieldsRelPositions grid)
  where
    -- | Convert relative positions (with respect to the grid) to absolute
    -- positions (with respect to the screen).
    gridFieldsAbsPositions' :: [(Field, RelScreenPosition)] -> [(Field, ScreenPosition)]
    gridFieldsAbsPositions' = fmap (\(fld, (x, y)) -> (fld, (x + screenMarginWH, y + screenMarginWH)))

-- | The relative screen positions of fields with respect to a grid. That is,
-- the field with logical position (x, y) within the grid has position
-- (x * fieldWidth + x * screenMarginWH, y * fieldHeight + y * screenMarginWH).
gridFieldsRelPositions :: Grid -> [(Field, RelScreenPosition)]
gridFieldsRelPositions grid = concatMap (fmap (\field -> (field, relPos field))) grid
 where
   (fW, fH) = gridFieldSize grid

   relPos :: Field -> RelScreenPosition
   relPos fld = (xPos * fW  + xPos * screenMarginWH, yPos * fH + yPos * screenMarginWH)
     where
       (xPos, yPos) = findPosition grid fld

-- | Calculate the field size.
-- PRE: The screen is a square ('screenWH').

-- Fields are squares.
-- Field size depends on the amount of columns and rows.
--   Use the larger one because it also needs to fit
-- Leave space for margin (left and right: 2 times).
--   Probably the margin to the right site or to the bottom is larger
--   but at least the space of 1 margin is given.
-- Leave space for margins between fields, that is:
--  (maxColRrow - 1) * fieldMargin.
gridFieldSize :: Grid -> Size
gridFieldSize grid = (fs, fs)
  where
    fs         = fieldSpace `div` maxCR
    fieldSpace = screenWH - (2 * screenMarginWH)
                          - ((maxCR - 1) * screenMarginWH)

    maxCR      = gridMaxLength grid

-- | Get the maximal size for a given grid.
--   That is, the maximum of the longest column and row.
gridMaxLength :: Grid -> Int
gridMaxLength grid = max maxColumn maxRow
  where
    maxColumn = gridLongestColumn grid
    maxRow    = gridLongestColumn $ transpose grid

    -- If you wonder where in this functions the arguments are, search for `eta
    -- conversion` and `pointfree style`.
    gridLongestColumn = maximum . map length

-- * Auxiliary Types

-- ** Visual Element

-- | A visual element with color, size and position.
type VElement = (Color, Size, Position) -- ((color, (width, height), (xPos, yPos))

-- | The color of an element.
vElementColor :: VElement -> Color
vElementColor (color, _, _) = color

-- | The size of an element.
vElementSize :: VElement -> Size
vElementSize (_, fldSize, _) = fldSize

-- | The position of an element.
vElementPosition :: VElement -> Position
vElementPosition (_, _, position) = position

-- ** Dimensions

-- | Defines a field size with (width, height).
type Size = (Int, Int)

-- | Define a position with (x, y).
type Position = (Int, Int)

-- | Define a screen position with (x, y).
type ScreenPosition = (Int, Int)

-- | Define a relative screen position with (x, y).
--
-- In this game it is used to to handle relative screen positions of fields within a grid.
type RelScreenPosition = (Int, Int)

-- * Auxiliary functions

-- | Convert 'Int' to 'Int16'.
toInt16 :: Int -> Int16
toInt16 i = fromIntegral i :: Int16

-- | Convert 'Int' to 'CInt'.
toCInt :: Int -> CInt
toCInt i = CInt (fromIntegral i :: Int32)