haskanoid-0.1.2: src/Input.hs

{-# LANGUAGE ExistentialQuantification #-}
-- | Defines an abstraction for the game controller and the functions to read
-- it.
--
-- Lower-level devices replicate the higher-level API, and should accomodate to
-- it. Each device should:
--
--    - Upon initialisation, return any necessary information to poll it again.
--
--    - Update the controller with its own values upon sensing.
--
-- In this case, we only have two: a wiimote and a mouse/keyboard combination.
-- If the wiimote is available, then the mouse isn't used.
--
-- It's very easy to add new devices. In particular, adding a Kinect using the
-- freenect library is easy (see github.com/keera-studios/freenect) for an
-- updated version.
--
-- Limitations:
-- 
--    - Device failures are not handled.
--
--    - Falling back to the next available device when there's a problem.
--
--    - Keymap configuration (having an intermediate Action-based layer).
--
--    - Using more than one device at a time. Changing that would be a one-line
--    patch.
--
module Input where

import Control.Monad
import Control.Monad.IfElse
import Data.IORef
import Data.Maybe (fromJust)
import Graphics.UI.SDL as SDL
import System.CWiid

import Control.Extra.Monad
import Graphics.UI.Extra.SDL

import Constants

-- * Game controller

-- | Controller info at any given point.
data Controller = Controller
  { controllerPos   :: (Double, Double)
  , controllerClick :: Bool
  , controllerPause :: Bool
  }

-- | Controller info at any given point, plus a pointer
-- to poll the main device again. This is safe,
-- since there is only one writer at a time (the device itself).
newtype ControllerRef =
  ControllerRef (IORef Controller, Controller -> IO Controller)

-- * General API

-- | Initialize the available input devices. This operation
-- returns a reference to a controller, which enables
-- getting its state as many times as necessary. It does
-- not provide any information about its nature, abilities, etc.
initializeInputDevices :: IO ControllerRef
initializeInputDevices = do
  dev <- do wm <- wiimoteDev
            case wm of
              Nothing  -> fmap fromJust sdlMouseKB
              Just wm' -> return wm'
  nr <- newIORef defaultInfo
  return $ ControllerRef (nr, dev)
 where defaultInfo = Controller (0,0) False False

-- | Sense from the controller, providing its current
-- state. This should return a new Controller state
-- if available, or the last one there was.
-- 
-- It is assumed that the sensing function is always
-- callable, and that it knows how to update the
-- Controller info if necessary.
senseInput :: ControllerRef -> IO Controller
senseInput (ControllerRef (cref, sensor)) = do
  cinfo <- readIORef cref
  cinfo' <- sensor cinfo
  writeIORef cref cinfo'
  return cinfo'

type ControllerDev = IO (Maybe (Controller -> IO Controller))

-- * WiiMote API (mid-level)

-- | The wiimote controller as defined using this
-- abstract interface. See 'initializeWiimote'.
wiimoteDev :: ControllerDev
wiimoteDev = initializeWiimote

-- ** Initialisation

-- | Initializes the wiimote, optionally returning the sensing function. It
-- returns Nothing if the Wiimote cannot be detected. Users should have a BT
-- device and press 1+2 to connect to it. A message is shown on stdout.
initializeWiimote :: ControllerDev
initializeWiimote = do
  putStrLn "Initializing WiiMote. Please press 1+2 to connect."
  wm <- cwiidOpen
  awhen wm (void . (`cwiidSetRptMode` 15)) -- Enable button reception, acc and IR
  case wm of
    Nothing  -> return Nothing
    Just wm' -> return $ Just $ senseWiimote wm'

-- ** Sensing

-- | Sense the Wiimote and update the controller.
--
-- This operation uses the IR for the controller's position,
-- and the main (A) button for the click.
--
-- TODO: Allow configuring the button and using other motion mechamisms
-- (accelerometers).
--
-- TODO: This should be split in two operations. One that presents a nice
-- Wii-like interface and one that actually updates the controller
senseWiimote :: CWiidWiimote -> Controller -> IO Controller
senseWiimote wiimote controller = do
  flags <- cwiidGetBtnState wiimote
  irs   <- cwiidGetIR wiimote

  -- Obtain positions of leds 1 and 2 (with a normal wii bar, those
  -- will be the ones we use).
  let led1   = irs!!0
      led2   = irs!!1

  -- Calculate mid point between sensor bar leds
  let posX = ((cwiidIRSrcPosX led1) + (cwiidIRSrcPosX led2)) `div` 2
      posY = ((cwiidIRSrcPosY led1) + (cwiidIRSrcPosY led2)) `div` 2

  -- Calculate proportional coordinates
  let propX = fromIntegral (1024 - posX) / 1024.0
      propY = fromIntegral (max 0 (posY - 384)) / 384.0

  -- Calculate game area coordinates
  let finX  = width  * propX
      finY  = height * propY

  -- Direction (old system based on buttons)
  -- let isLeft  = cwiidIsBtnPushed flags cwiidBtnLeft
  --     isRight = cwiidIsBtnPushed flags cwiidBtnRight 
  --     (x,y)   = controllerPos controller
  --     x'      = if isLeft then x - wiiXDiff else if isRight then x + wiiXDiff else x
  --     x''     = inRange (0, gameWidth) x' 
  --     pos'    = (x'', y)
  -- wiiXDiff :: Float
  -- wiiXDiff = 6

  -- Clicks
  let isClick = cwiidIsBtnPushed flags cwiidBtnA

  -- Update state
  return (controller { controllerPos   = (finX, finY) -- pos'
                     , controllerClick = isClick
                     })

-- * SDL API (mid-level)

-- ** Initialization

-- | Dummy initialization. No device is actually initialized.
sdlMouseKB :: ControllerDev
sdlMouseKB = return (Just sdlGetController)

-- ** Sensing

-- | Sense the SDL keyboard and mouse and update
-- the controller. It only senses the mouse position,
-- the primary mouse button, and the p key to pause
-- the game.
--
-- We need a non-blocking controller-polling function.
-- TODO: Check http://gameprogrammer.com/fastevents/fastevents1.html
sdlGetController :: Controller -> IO Controller
sdlGetController info =
  foldLoopM info pollEvent (not.isEmptyEvent) ((return .) . handleEvent)

-- | Handles one event only and returns the updated controller.
handleEvent :: Controller -> SDL.Event -> Controller
handleEvent c e =
  case e of
    MouseMotion x y _ _                -> c { controllerPos   = (fromIntegral x, fromIntegral y)}
    MouseButtonDown _ _ ButtonLeft     -> c { controllerClick = True }
    MouseButtonUp   _ _ ButtonLeft     -> c { controllerClick = False} 
    KeyUp (Keysym { symKey = SDLK_p }) -> c { controllerPause = not (controllerPause c) }
    _                                  -> c