Button.hs

{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE DuplicateRecordFields  #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeSynonymInstances  #-}
{-# LANGUAGE FlexibleInstances  #-}
{-# LANGUAGE OverloadedStrings  #-}

module Play.Engine.Button where

import qualified SDL
import qualified SDL.Font as SDLF

import Play.Engine
import Control.Lens
import SDL.Vect (V4(..))
import qualified Data.Text as T


data Button
  = Button
  { _font :: SDLF.Font
  , _text :: T.Text
  , _pos :: {-# UNPACK #-} !IPoint
  , _size :: {-# UNPACK #-} !IPoint
  , _isClicked :: Bool
  }

makeFieldsNoPrefix ''Button

make :: IPoint -> Size -> SDLF.Font -> T.Text -> Button
make posi sz fnt txt = do
  Button
    { _font = fnt
    , _text = txt
    , _pos = posi
    , _size = sz
    , _isClicked = False
    }

update :: Input -> Button -> Result (Bool, Button)
update input btn =
  pure
    $ (keyClicked KeyStart input || keyClicked KeyA input,)
    $ btn
    & over isClicked (|| keyClicked KeyStart input || keyClicked KeyA input)

render :: SDL.Renderer -> Bool -> Button -> IO ()
render renderer marked btn
  | btn ^. size == Point 0 0 =
    pure ()
  | otherwise = do
  let
    rect = toRect (btn ^. pos) (btn ^. size)

  SDL.rendererDrawColor renderer SDL.$= V4 0 0 0 255
  SDL.fillRect renderer (Just rect)
  SDL.rendererDrawColor renderer SDL.$= V4 100 (if marked then 255 else 130) (if btn ^. isClicked then 255 else 180) 255
  SDL.drawRect renderer (Just rect)

  if T.length (btn ^. text) < 1
    then pure ()
    else do
      txt <- SDL.createTextureFromSurface renderer
        =<< SDLF.solid (btn ^. font) (V4 255 255 255 255) (btn ^. text)
      ti <- SDL.queryTexture txt
      let
        loc =
          Point
            (btn ^. pos . x + ((btn ^. size . x - fromIntegral (SDL.textureWidth  ti)) `div` 2))
            (btn ^. pos . y + ((btn ^. size . y - fromIntegral (SDL.textureHeight ti)) `div` 2))
      SDL.copy
        renderer
        txt
        Nothing
        (Just $ toRect
          loc
          (Point (fromIntegral $ SDL.textureWidth ti) (fromIntegral $ SDL.textureHeight ti))
        )
      SDL.destroyTexture txt